From ae6bcfbf0e7ccae46f57a171be40b0c78fc73ab9 Mon Sep 17 00:00:00 2001 From: i Date: Sat, 29 Aug 2026 17:54:43 -0400 Subject: [PATCH 01/80] test: pin units time and interval semantics first --- examples/units-time-intervals/Tests.idric | 199 ++++++++++++++++++++++ 1 file changed, 199 insertions(+) create mode 100644 examples/units-time-intervals/Tests.idric diff --git a/examples/units-time-intervals/Tests.idric b/examples/units-time-intervals/Tests.idric new file mode 100644 index 0000000000..ad8300db69 --- /dev/null +++ b/examples/units-time-intervals/Tests.idric @@ -0,0 +1,199 @@ +module Tests + +import UnitsTimeIntervals + +%default total + +-- Tests first. This file deliberately pins only the small algebraically +-- settled kernel from the August 29, 2026 type-system discussion. +-- +-- Not in this first slice: calendar months/time zones, probability or Gaussian +-- inference, correlated uncertainty, interval multiplication/division, or an +-- algebraic inheritance hierarchy. + +-- -------------------------------------------------------------------------- +-- 1. Exact units and dimensional analysis +-- -------------------------------------------------------------------------- + +inch_metric_definition_test : + quantityEqual + (inches (whole 1)) + (metres (fraction 127 5000)) = True +inch_metric_definition_test = Refl + +foot_inches_test : + quantityEqual + (feet (whole 1)) + (inches (whole 12)) = True +foot_inches_test = Refl + +quarter_plus_sixteenth_inch_test : + quantityEqual + (addQuantity + (inches (fraction 1 4)) + (inches (fraction 1 16))) + (inches (fraction 5 16)) = True +quarter_plus_sixteenth_inch_test = Refl + +centimetre_metre_test : + quantityEqual + (centimetres (whole 100)) + (metres (whole 1)) = True +centimetre_metre_test = Refl + +millimetre_metre_test : + quantityEqual + (millimetres (whole 1000)) + (metres (whole 1)) = True +millimetre_metre_test = Refl + +us_volume_relations_test : + quantityEqual + (usCups (whole 16)) + (usGallons (whole 1)) = True +us_volume_relations_test = Refl + +us_pints_relation_test : + quantityEqual + (usPints (whole 8)) + (usGallons (whole 1)) = True +us_pints_relation_test = Refl + +us_quarts_relation_test : + quantityEqual + (usQuarts (whole 4)) + (usGallons (whole 1)) = True +us_quarts_relation_test = Refl + +-- No special GallonsPerSecond class is declared. The result type follows from +-- division of the dimension exponents. +one_gallon_per_second : Quantity volumeFlowDimension +one_gallon_per_second = + divideQuantity + (usGallons (whole 1)) + (secondsQuantity (whole 1)) + +metres_per_second_squared : Quantity accelerationDimension +metres_per_second_squared = + divideQuantity + (divideQuantity + (metres (whole 1)) + (secondsQuantity (whole 1))) + (secondsQuantity (whole 1)) + +-- -------------------------------------------------------------------------- +-- 2. Instant + signed Duration +-- -------------------------------------------------------------------------- + +five_minutes_after_test : + instantEqual + (plusDuration (instant (whole 1000)) (minutes (whole 5))) + (instant (whole 1300)) = True +five_minutes_after_test = Refl + +five_minutes_before_test : + instantEqual + (minusDuration (instant (whole 1000)) (minutes (whole 5))) + (instant (whole 700)) = True +five_minutes_before_test = Refl + +instant_difference_test : + durationEqual + (instantDifference (instant (whole 700)) (instant (whole 1000))) + (minutes (whole 5)) = True +instant_difference_test = Refl + +signed_duration_subtraction_test : + durationEqual + (subtractDuration (minutes (whole 5)) (minutes (whole 8))) + (minutes (whole (-3))) = True +signed_duration_subtraction_test = Refl + +duration_inverse_test : + durationEqual + (addDuration (minutes (whole 5)) (negateDuration (minutes (whole 5)))) + (seconds (whole 0)) = True +duration_inverse_test = Refl + +minute_definition_test : + durationEqual (minutes (whole 1)) (seconds (whole 60)) = True +minute_definition_test = Refl + +hour_definition_test : + durationEqual (hours (whole 1)) (minutes (whole 60)) = True +hour_definition_test = Refl + +-- -------------------------------------------------------------------------- +-- 3. One-dimensional exact rational intervals +-- -------------------------------------------------------------------------- + +closed_lower_endpoint_is_member_test : + contains + (closedInterval (whole 1) (whole 3)) + (whole 1) = True +closed_lower_endpoint_is_member_test = Refl + +open_lower_endpoint_is_not_member_test : + contains + (openInterval (whole 1) (whole 3)) + (whole 1) = False +open_lower_endpoint_is_not_member_test = Refl + +closed_upper_endpoint_is_member_test : + contains + (closedInterval (whole 1) (whole 3)) + (whole 3) = True +closed_upper_endpoint_is_member_test = Refl + +open_upper_endpoint_is_not_member_test : + contains + (openInterval (whole 1) (whole 3)) + (whole 3) = False +open_upper_endpoint_is_not_member_test = Refl + +closed_interval_addition_test : + intervalEqual + (addInterval + (closedInterval (whole 1) (whole 3)) + (closedInterval (whole 4) (whole 9))) + (closedInterval (whole 5) (whole 12)) = True +closed_interval_addition_test = Refl + +mixed_open_interval_addition_test : + intervalEqual + (addInterval + (rightOpenInterval (whole 1) (whole 3)) + (leftOpenInterval (whole 4) (whole 9))) + (openInterval (whole 5) (whole 12)) = True +mixed_open_interval_addition_test = Refl + +-- Opening a boundary records a one-way loss of endpoint membership. The API +-- intentionally does not offer "add epsilon back and close it" as an inverse. +open_left_removes_endpoint_test : + contains + (openLeft (closedInterval (whole 1) (whole 3))) + (whole 1) = False +open_left_removes_endpoint_test = Refl + +open_right_removes_endpoint_test : + contains + (openRight (closedInterval (whole 1) (whole 3))) + (whole 3) = False +open_right_removes_endpoint_test = Refl + +-- -------------------------------------------------------------------------- +-- 4. Nilpotent epsilon remains available, but is not ordered +-- -------------------------------------------------------------------------- + +-- The same epsilon glyph motivates the endpoint spelling, but the types remain +-- distinct: this epsilon is the dual-number tangent infinitesimal satisfying +-- epsilon^2 = 0. Interval openness is represented by endpoint membership, not +-- by pretending this nilpotent value can be positive in an ordered ring. +epsilon_squared_test : + dualEqual + (dualMultiply epsilon epsilon) + dualZero = True +epsilon_squared_test = Refl + +main : IO () +main = putStrLn "units, time, intervals: tests typecheck" From 57de2109ff81b4f4bf7f2610a63d34b5278b3804 Mon Sep 17 00:00:00 2001 From: i Date: Sat, 29 Aug 2026 17:55:33 -0400 Subject: [PATCH 02/80] feat: add exact units signed time and interval core --- .../UnitsTimeIntervals.idric | 438 ++++++++++++++++++ 1 file changed, 438 insertions(+) create mode 100644 examples/units-time-intervals/UnitsTimeIntervals.idric diff --git a/examples/units-time-intervals/UnitsTimeIntervals.idric b/examples/units-time-intervals/UnitsTimeIntervals.idric new file mode 100644 index 0000000000..0261c077b3 --- /dev/null +++ b/examples/units-time-intervals/UnitsTimeIntervals.idric @@ -0,0 +1,438 @@ +module UnitsTimeIntervals + +%default total + +-- This is deliberately a small executable mathematical kernel, not a general +-- units/time/uncertainty framework. The type checker should establish the +-- settled algebra here without forcing the user to advertise a hierarchy of +-- Group/Semigroup/etc. interfaces in ordinary source. + +-- -------------------------------------------------------------------------- +-- Exact rational scalar used by the first fixtures +-- -------------------------------------------------------------------------- + +public export +data Rat = MkRat Integer Integer + +-- First-pass invariant: callers use a nonzero positive denominator. The +-- constructors below preserve that invariant for every checked-in fixture. +-- A later library can hide MkRat and normalize/reject arbitrary denominators; +-- that representation question is intentionally not needed for these tests. +public export +whole : Integer -> Rat +whole n = MkRat n 1 + +public export +fraction : Integer -> Integer -> Rat +fraction n d = MkRat n d + +public export +ratAdd : Rat -> Rat -> Rat +ratAdd (MkRat a b) (MkRat c d) = + MkRat (a * d + c * b) (b * d) + +public export +ratNegate : Rat -> Rat +ratNegate (MkRat a b) = MkRat (-a) b + +public export +ratSubtract : Rat -> Rat -> Rat +ratSubtract left right = ratAdd left (ratNegate right) + +public export +ratMultiply : Rat -> Rat -> Rat +ratMultiply (MkRat a b) (MkRat c d) = MkRat (a * c) (b * d) + +public export +ratDivide : Rat -> Rat -> Rat +ratDivide (MkRat a b) (MkRat c d) = MkRat (a * d) (b * c) + +public export +ratEqual : Rat -> Rat -> Bool +ratEqual (MkRat a b) (MkRat c d) = (a * d) == (c * b) + +-- The first interval kernel uses positive denominators, so cross multiplication +-- preserves order without a sign case split. +public export +ratLess : Rat -> Rat -> Bool +ratLess (MkRat a b) (MkRat c d) = (a * d) < (c * b) + +public export +ratLessOrEqual : Rat -> Rat -> Bool +ratLessOrEqual left right = ratLess left right || ratEqual left right + +-- -------------------------------------------------------------------------- +-- Physical dimensions and exact unit scales +-- -------------------------------------------------------------------------- + +-- Exponents are ordered Length, Mass, Time. That is enough for the first +-- length/volume/flow/acceleration examples. Extending the basis later is a +-- representation change, not a reason to delay these laws. +public export +data Dimension = Dim Integer Integer Integer + +public export +lengthDimension : Dimension +lengthDimension = Dim 1 0 0 + +public export +massDimension : Dimension +massDimension = Dim 0 1 0 + +public export +timeDimension : Dimension +timeDimension = Dim 0 0 1 + +public export +volumeDimension : Dimension +volumeDimension = Dim 3 0 0 + +public export +volumeFlowDimension : Dimension +volumeFlowDimension = Dim 3 0 (-1) + +public export +accelerationDimension : Dimension +accelerationDimension = Dim 1 0 (-2) + +public export +multiplyDimension : Dimension -> Dimension -> Dimension +multiplyDimension (Dim l1 m1 t1) (Dim l2 m2 t2) = + Dim (l1 + l2) (m1 + m2) (t1 + t2) + +public export +divideDimension : Dimension -> Dimension -> Dimension +divideDimension (Dim l1 m1 t1) (Dim l2 m2 t2) = + Dim (l1 - l2) (m1 - m2) (t1 - t2) + +public export +data Quantity : Dimension -> Type where + MkQuantity : Rat -> Quantity dimension + +public export +quantityValue : Quantity dimension -> Rat +quantityValue (MkQuantity value) = value + +public export +quantityEqual : Quantity dimension -> Quantity dimension -> Bool +quantityEqual (MkQuantity left) (MkQuantity right) = ratEqual left right + +public export +addQuantity : Quantity dimension -> Quantity dimension -> Quantity dimension +addQuantity (MkQuantity left) (MkQuantity right) = + MkQuantity (ratAdd left right) + +public export +subtractQuantity : Quantity dimension -> Quantity dimension -> Quantity dimension +subtractQuantity (MkQuantity left) (MkQuantity right) = + MkQuantity (ratSubtract left right) + +public export +multiplyQuantity : + {leftDimension : Dimension} -> + {rightDimension : Dimension} -> + Quantity leftDimension -> + Quantity rightDimension -> + Quantity (multiplyDimension leftDimension rightDimension) +multiplyQuantity (MkQuantity left) (MkQuantity right) = + MkQuantity (ratMultiply left right) + +public export +divideQuantity : + {leftDimension : Dimension} -> + {rightDimension : Dimension} -> + Quantity leftDimension -> + Quantity rightDimension -> + Quantity (divideDimension leftDimension rightDimension) +divideQuantity (MkQuantity left) (MkQuantity right) = + MkQuantity (ratDivide left right) + +-- Length. Metre is the canonical scalar used internally in this fixture. +public export +metres : Rat -> Quantity lengthDimension +metres amount = MkQuantity amount + +public export +centimetres : Rat -> Quantity lengthDimension +centimetres amount = MkQuantity (ratMultiply amount (fraction 1 100)) + +public export +millimetres : Rat -> Quantity lengthDimension +millimetres amount = MkQuantity (ratMultiply amount (fraction 1 1000)) + +public export +inches : Rat -> Quantity lengthDimension +inches amount = MkQuantity (ratMultiply amount (fraction 127 5000)) + +public export +feet : Rat -> Quantity lengthDimension +feet amount = MkQuantity (ratMultiply amount (fraction 381 1250)) + +-- Time as an ordinary physical dimension, for compound quantities such as +-- volume/time. This is separate from Instant below: an instant is a point, +-- while a time-dimensional quantity is an elapsed displacement. +public export +secondsQuantity : Rat -> Quantity timeDimension +secondsQuantity amount = MkQuantity amount + +-- Volume. Cubic metre is canonical. 1 litre = 1/1000 m^3 exactly. +public export +litres : Rat -> Quantity volumeDimension +litres amount = MkQuantity (ratMultiply amount (fraction 1 1000)) + +-- US customary liquid units are named explicitly. Do not silently identify +-- these with imperial gallons/pints. The US gallon is exactly 231 cubic inches, +-- hence exactly 473176473 / 125000000000 cubic metres. +public export +usGallons : Rat -> Quantity volumeDimension +usGallons amount = + MkQuantity + (ratMultiply amount (fraction 473176473 125000000000)) + +public export +usQuarts : Rat -> Quantity volumeDimension +usQuarts amount = usGallons (ratDivide amount (whole 4)) + +public export +usPints : Rat -> Quantity volumeDimension +usPints amount = usGallons (ratDivide amount (whole 8)) + +public export +usCups : Rat -> Quantity volumeDimension +usCups amount = usGallons (ratDivide amount (whole 16)) + +-- -------------------------------------------------------------------------- +-- Instant + signed Duration +-- -------------------------------------------------------------------------- + +-- No calendar semantics here. The coordinate is an arbitrary exact elapsed +-- second coordinate used only to make the affine point/displacement laws +-- executable. No epoch, timezone, month, DST, or leap-second policy is claimed. +public export +data Duration = MkDuration Rat + +public export +data Instant = MkInstant Rat + +public export +seconds : Rat -> Duration +seconds amount = MkDuration amount + +public export +minutes : Rat -> Duration +minutes amount = seconds (ratMultiply amount (whole 60)) + +public export +hours : Rat -> Duration +hours amount = minutes (ratMultiply amount (whole 60)) + +public export +instant : Rat -> Instant +instant coordinate = MkInstant coordinate + +public export +durationEqual : Duration -> Duration -> Bool +durationEqual (MkDuration left) (MkDuration right) = ratEqual left right + +public export +instantEqual : Instant -> Instant -> Bool +instantEqual (MkInstant left) (MkInstant right) = ratEqual left right + +public export +addDuration : Duration -> Duration -> Duration +addDuration (MkDuration left) (MkDuration right) = + MkDuration (ratAdd left right) + +public export +negateDuration : Duration -> Duration +negateDuration (MkDuration value) = MkDuration (ratNegate value) + +public export +subtractDuration : Duration -> Duration -> Duration +subtractDuration left right = addDuration left (negateDuration right) + +public export +plusDuration : Instant -> Duration -> Instant +plusDuration (MkInstant point) (MkDuration displacement) = + MkInstant (ratAdd point displacement) + +public export +minusDuration : Instant -> Duration -> Instant +minusDuration point displacement = plusDuration point (negateDuration displacement) + +-- Read as: instantDifference earlier later = later - earlier. +public export +instantDifference : Instant -> Instant -> Duration +instantDifference (MkInstant earlier) (MkInstant later) = + MkDuration (ratSubtract later earlier) + +-- -------------------------------------------------------------------------- +-- One-dimensional exact rational intervals +-- -------------------------------------------------------------------------- + +-- We intentionally keep endpoint membership as data. The epsilon names make +-- the familiar "a + epsilon" / "b - epsilon" intuition available in the type +-- vocabulary, but they do not pretend that the nilpotent dual epsilon below is +-- an ordered positive number. A nonzero ordered epsilon cannot satisfy +-- epsilon^2 = 0 in an ordered ring. +public export +data LowerBoundary + = IncludeLower + | LowerPlusEpsilon + +public export +data UpperBoundary + = IncludeUpper + | UpperMinusEpsilon + +public export +data Interval a + = EmptyInterval + | Span LowerBoundary a a UpperBoundary + +public export +lowerIncluded : LowerBoundary -> Bool +lowerIncluded IncludeLower = True +lowerIncluded LowerPlusEpsilon = False + +public export +upperIncluded : UpperBoundary -> Bool +upperIncluded IncludeUpper = True +upperIncluded UpperMinusEpsilon = False + +public export +makeInterval : LowerBoundary -> Rat -> Rat -> UpperBoundary -> Interval Rat +makeInterval lower lo hi upper = + if ratLess hi lo + then EmptyInterval + else if ratEqual lo hi + then if lowerIncluded lower && upperIncluded upper + then Span lower lo hi upper + else EmptyInterval + else Span lower lo hi upper + +public export +closedInterval : Rat -> Rat -> Interval Rat +closedInterval lo hi = makeInterval IncludeLower lo hi IncludeUpper + +public export +openInterval : Rat -> Rat -> Interval Rat +openInterval lo hi = makeInterval LowerPlusEpsilon lo hi UpperMinusEpsilon + +public export +leftOpenInterval : Rat -> Rat -> Interval Rat +leftOpenInterval lo hi = makeInterval LowerPlusEpsilon lo hi IncludeUpper + +public export +rightOpenInterval : Rat -> Rat -> Interval Rat +rightOpenInterval lo hi = makeInterval IncludeLower lo hi UpperMinusEpsilon + +public export +openLeft : Interval Rat -> Interval Rat +openLeft EmptyInterval = EmptyInterval +openLeft (Span _ lo hi upper) = + makeInterval LowerPlusEpsilon lo hi upper + +public export +openRight : Interval Rat -> Interval Rat +openRight EmptyInterval = EmptyInterval +openRight (Span lower lo hi _) = + makeInterval lower lo hi UpperMinusEpsilon + +public export +lowerAllows : LowerBoundary -> Rat -> Rat -> Bool +lowerAllows IncludeLower lo value = ratLessOrEqual lo value +lowerAllows LowerPlusEpsilon lo value = ratLess lo value + +public export +upperAllows : UpperBoundary -> Rat -> Rat -> Bool +upperAllows IncludeUpper hi value = ratLessOrEqual value hi +upperAllows UpperMinusEpsilon hi value = ratLess value hi + +public export +contains : Interval Rat -> Rat -> Bool +contains EmptyInterval _ = False +contains (Span lower lo hi upper) value = + lowerAllows lower lo value && upperAllows upper hi value + +public export +sameLowerBoundary : LowerBoundary -> LowerBoundary -> Bool +sameLowerBoundary IncludeLower IncludeLower = True +sameLowerBoundary LowerPlusEpsilon LowerPlusEpsilon = True +sameLowerBoundary _ _ = False + +public export +sameUpperBoundary : UpperBoundary -> UpperBoundary -> Bool +sameUpperBoundary IncludeUpper IncludeUpper = True +sameUpperBoundary UpperMinusEpsilon UpperMinusEpsilon = True +sameUpperBoundary _ _ = False + +public export +intervalEqual : Interval Rat -> Interval Rat -> Bool +intervalEqual EmptyInterval EmptyInterval = True +intervalEqual + (Span lower1 lo1 hi1 upper1) + (Span lower2 lo2 hi2 upper2) = + sameLowerBoundary lower1 lower2 && + ratEqual lo1 lo2 && + ratEqual hi1 hi2 && + sameUpperBoundary upper1 upper2 +intervalEqual _ _ = False + +public export +addLowerBoundary : LowerBoundary -> LowerBoundary -> LowerBoundary +addLowerBoundary IncludeLower IncludeLower = IncludeLower +addLowerBoundary _ _ = LowerPlusEpsilon + +public export +addUpperBoundary : UpperBoundary -> UpperBoundary -> UpperBoundary +addUpperBoundary IncludeUpper IncludeUpper = IncludeUpper +addUpperBoundary _ _ = UpperMinusEpsilon + +public export +addInterval : Interval Rat -> Interval Rat -> Interval Rat +addInterval EmptyInterval _ = EmptyInterval +addInterval _ EmptyInterval = EmptyInterval +addInterval + (Span lower1 lo1 hi1 upper1) + (Span lower2 lo2 hi2 upper2) = + makeInterval + (addLowerBoundary lower1 lower2) + (ratAdd lo1 lo2) + (ratAdd hi1 hi2) + (addUpperBoundary upper1 upper2) + +-- Deliberately absent: a closeLeft/closeRight operation that pretends opening +-- with epsilon was invertible. Once endpoint membership has been discarded, +-- closing the set is a new operation/claim, not algebraic cancellation. + +-- -------------------------------------------------------------------------- +-- Dual-number epsilon: same notation family, distinct type and semantics +-- -------------------------------------------------------------------------- + +public export +data Dual = MkDual Rat Rat + +public export +dualZero : Dual +dualZero = MkDual (whole 0) (whole 0) + +public export +epsilon : Dual +epsilon = MkDual (whole 0) (whole 1) + +public export +dualMultiply : Dual -> Dual -> Dual +dualMultiply (MkDual a b) (MkDual c d) = + MkDual + (ratMultiply a c) + (ratAdd (ratMultiply a d) (ratMultiply b c)) + +public export +dualEqual : Dual -> Dual -> Bool +dualEqual (MkDual a b) (MkDual c d) = + ratEqual a c && ratEqual b d + +-- No Ord/ordering operation is supplied for Dual. This is intentional: the +-- nilpotent epsilon belongs to first-order/tangent algebra, while interval +-- openness belongs to endpoint membership/order semantics. From 5421a8ac06d0a762a0bf8b35e8a425da30a0caed Mon Sep 17 00:00:00 2001 From: i Date: Sat, 29 Aug 2026 17:56:04 -0400 Subject: [PATCH 03/80] test: compile units time and intervals with real compiler --- tests/idris2/basic/edric007/run | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 tests/idris2/basic/edric007/run diff --git a/tests/idris2/basic/edric007/run b/tests/idris2/basic/edric007/run new file mode 100644 index 0000000000..999ebcf965 --- /dev/null +++ b/tests/idris2/basic/edric007/run @@ -0,0 +1,7 @@ +. ../../../testutils.sh + +cp ../../../../examples/units-time-intervals/UnitsTimeIntervals.idric UnitsTimeIntervals.idr +cp ../../../../examples/units-time-intervals/Tests.idric Tests.idr + +"$idris2" Tests.idr -o units-time-intervals >/dev/null +./build/exec/units-time-intervals From 1583eae1cdee3ac04002af0d041970c48f56063e Mon Sep 17 00:00:00 2001 From: i Date: Sat, 29 Aug 2026 17:56:10 -0400 Subject: [PATCH 04/80] test: record units time intervals compiler receipt output --- tests/idris2/basic/edric007/expected | 1 + 1 file changed, 1 insertion(+) create mode 100644 tests/idris2/basic/edric007/expected diff --git a/tests/idris2/basic/edric007/expected b/tests/idris2/basic/edric007/expected new file mode 100644 index 0000000000..c76749599c --- /dev/null +++ b/tests/idris2/basic/edric007/expected @@ -0,0 +1 @@ +units, time, intervals: tests typecheck From f2f543f56179653efe3592acf5a55f0ce3fe6009 Mon Sep 17 00:00:00 2001 From: i Date: Sat, 29 Aug 2026 17:56:17 -0400 Subject: [PATCH 05/80] test: include units time intervals in Edric smoke suite --- edric | 1 + 1 file changed, 1 insertion(+) diff --git a/edric b/edric index 2d563dcaa9..2bcee11b8d 100755 --- a/edric +++ b/edric @@ -41,6 +41,7 @@ smoke_test() { "$make_command" -C "$repo_root" test only=idris2/basic/edric004 "$make_command" -C "$repo_root" test only=idris2/basic/edric005 "$make_command" -C "$repo_root" test only=idris2/basic/edric006 + "$make_command" -C "$repo_root" test only=idris2/basic/edric007 } command=${1:-all} From cf97e690a352a11a8b3a60d89cf704282a7bbee6 Mon Sep 17 00:00:00 2001 From: i Date: Sat, 29 Aug 2026 17:57:28 -0400 Subject: [PATCH 06/80] ci: run focused Edric type-system smoke test --- .github/workflows/ci-edric-types.yml | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 .github/workflows/ci-edric-types.yml diff --git a/.github/workflows/ci-edric-types.yml b/.github/workflows/ci-edric-types.yml new file mode 100644 index 0000000000..b118d49446 --- /dev/null +++ b/.github/workflows/ci-edric-types.yml @@ -0,0 +1,24 @@ +name: Edric type-system smoke + +on: + pull_request: + paths: + - 'examples/units-time-intervals/**' + - 'tests/idris2/basic/edric007/**' + - 'edric' + - '.github/workflows/ci-edric-types.yml' + push: + paths: + - 'examples/units-time-intervals/**' + - 'tests/idris2/basic/edric007/**' + - 'edric' + - '.github/workflows/ci-edric-types.yml' + +jobs: + units-time-intervals: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + + - name: Bootstrap Edric and run focused smoke suite + run: ./edric all From a3ffc1c03e040e31a0867d473611b1bf8960cca0 Mon Sep 17 00:00:00 2001 From: i Date: Sat, 29 Aug 2026 18:00:40 -0400 Subject: [PATCH 07/80] test: make edric007 runner executable --- tests/idris2/basic/edric007/run | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100644 => 100755 tests/idris2/basic/edric007/run diff --git a/tests/idris2/basic/edric007/run b/tests/idris2/basic/edric007/run old mode 100644 new mode 100755 From 5b5c54da66cdc3795406891667a610ec038ecf9f Mon Sep 17 00:00:00 2001 From: i Date: Tue, 1 Sep 2026 21:38:35 -0400 Subject: [PATCH 08/80] Spell out compiler-internal TTImp vocabulary Replace opaque TTImp I-prefixed constructor and helper names with readable elaboratable-term vocabulary. Preserve public reflection spellings and serialized compatibility names. Validated with ./_/edric all. --- Idris/Desugar.idr | 300 ++++++++-------- Idris/Elab/Implementation.idr | 90 ++--- Idris/Elab/Interface.idr | 96 ++--- Idris/REPL.idr | 12 +- Idris/Resugar.idr | 118 +++--- Idris/Syntax.idr | 2 +- TTIMP_READABLE_NAMES.md | 88 +++++ TTImp/BindImplicits.idr | 140 ++++---- TTImp/Elab.idr | 6 +- TTImp/Elab/Ambiguity.idr | 74 ++-- TTImp/Elab/App.idr | 68 ++-- TTImp/Elab/Binders.idr | 2 +- TTImp/Elab/Case.idr | 40 +-- TTImp/Elab/ImplicitBind.idr | 2 +- TTImp/Elab/Local.idr | 46 +-- TTImp/Elab/Quote.idr | 120 +++---- TTImp/Elab/Record.idr | 30 +- TTImp/Elab/Rewrite.idr | 6 +- TTImp/Elab/Term.idr | 108 +++--- TTImp/Impossible.idr | 38 +- TTImp/Interactive/CaseSplit.idr | 56 +-- TTImp/Interactive/ExprSearch.idr | 2 +- TTImp/Interactive/GenerateDef.idr | 50 +-- TTImp/Interactive/Intro.idr | 8 +- TTImp/Interactive/MakeLemma.idr | 6 +- TTImp/Parser.idr | 102 +++--- TTImp/PartialEval.idr | 42 +-- TTImp/ProcessData.idr | 20 +- TTImp/ProcessDecls.idr | 32 +- TTImp/ProcessDef.idr | 24 +- TTImp/ProcessParams.idr | 6 +- TTImp/ProcessRecord.idr | 58 +-- TTImp/ProcessType.idr | 6 +- TTImp/Reflect.idr | 192 +++++----- TTImp/TTImp.idr | 574 +++++++++++++++--------------- TTImp/TTImp/Functor.idr | 184 +++++----- TTImp/TTImp/TTC.idr | 188 +++++----- TTImp/TTImp/Traversals.idr | 108 +++--- TTImp/Unelab.idr | 84 ++--- TTImp/Utils.idr | 384 ++++++++++---------- TTImp/WithClause.idr | 124 +++---- Yaffle/REPL.idr | 2 +- 42 files changed, 1863 insertions(+), 1775 deletions(-) create mode 100644 TTIMP_READABLE_NAMES.md diff --git a/Idris/Desugar.idr b/Idris/Desugar.idr index 5f3d290312..de32ef7b00 100644 --- a/Idris/Desugar.idr +++ b/Idris/Desugar.idr @@ -252,33 +252,33 @@ addNS _ n = n bindFun : FC -> Maybe Namespace -> RawImp -> RawImp -> RawImp bindFun fc ns ma f = let fc = virtualiseFC fc in - IApp fc (IApp fc (IVar fc (addNS ns $ UN $ Basic ">>=")) ma) f + Elaboratable_Apply fc (Elaboratable_Apply fc (Elaboratable_Name fc (addNS ns $ UN $ Basic ">>=")) ma) f seqFun : FC -> Maybe Namespace -> RawImp -> RawImp -> RawImp seqFun fc ns ma mb = let fc = virtualiseFC fc in - IApp fc (IApp fc (IVar fc (addNS ns (UN $ Basic ">>"))) ma) mb + Elaboratable_Apply fc (Elaboratable_Apply fc (Elaboratable_Name fc (addNS ns (UN $ Basic ">>"))) ma) mb bindBangs : List (Name, FC, RawImp) -> Maybe Namespace -> RawImp -> RawImp bindBangs [] ns tm = tm bindBangs ((n, fc, btm) :: bs) ns tm = bindBangs bs ns $ bindFun fc ns btm - $ ILam EmptyFC top Explicit (Just n) (Implicit fc False) tm + $ Elaboratable_Lambda EmptyFC top Explicit (Just n) (Implicit fc False) tm idiomise : FC -> Maybe Namespace -> Maybe Namespace -> RawImp -> RawImp -idiomise fc dons mns (IAlternative afc u alts) - = IAlternative afc (mapAltType (idiomise afc dons mns) u) (idiomise afc dons mns <$> alts) -idiomise fc dons mns (IApp afc f a) +idiomise fc dons mns (Elaboratable_Alternative afc u alts) + = Elaboratable_Alternative afc (mapAltType (idiomise afc dons mns) u) (idiomise afc dons mns <$> alts) +idiomise fc dons mns (Elaboratable_Apply afc f a) = let fc = virtualiseFC fc app = UN $ Basic "<*>" nm = maybe app (`NS` app) (mns <|> dons) - in IApp fc (IApp fc (IVar fc nm) (idiomise afc dons mns f)) a + in Elaboratable_Apply fc (Elaboratable_Apply fc (Elaboratable_Name fc nm) (idiomise afc dons mns f)) a idiomise fc dons mns fn = let fc = virtualiseFC fc pur = UN $ Basic "pure" nm = maybe pur (`NS` pur) (mns <|> dons) - in IApp fc (IVar fc nm) fn + in Elaboratable_Apply fc (Elaboratable_Name fc nm) fn data Bang : Type where @@ -294,8 +294,8 @@ mutual let ns = mbNamespace !(get Bang) let pur = UN $ Basic "pure" case x == pur of -- implicitly add namespace to unqualified occurrences of `pure` in a qualified do-block - False => pure $ IVar fc x - True => pure $ IVar fc (maybe pur (`NS` pur) ns) + False => pure $ Elaboratable_Name fc x + True => pure $ Elaboratable_Name fc (maybe pur (`NS` pur) ns) -- Desugaring forall n1, n2, n3 . s into -- {0 n1 : ?} -> {0 n2 : ?} -> {0 n3 : ?} -> s @@ -306,7 +306,7 @@ mutual (names : List (WithFC Name)) -> Core RawImp desugarForallNames ctx [] = desugarB side ctx scope desugarForallNames ctx (x :: xs) - = IPi x.fc erased Implicit (Just x.val) + = Elaboratable_Dependent_Function_Type x.fc erased Implicit (Just x.val) <$> desugarB side ps (PImplicit x.fc) <*> desugarForallNames (x.val :: ctx) xs @@ -322,7 +322,7 @@ mutual = desugarB side ctx scope desugarMultiBinder ctx (name :: xs) = let extendedCtx = name.val :: ps - in IPi binder.fc rig + in Elaboratable_Dependent_Function_Type binder.fc rig <$> mapDesugarPiInfo extendedCtx info <*> (pure (Just name.val)) <*> desugarB side ps type @@ -330,40 +330,40 @@ mutual desugarB side ps (PPi fc rig p mn argTy retTy) = let ps' = maybe ps (:: ps) mn in - pure $ IPi fc rig !(traverse (desugar side ps') p) + pure $ Elaboratable_Dependent_Function_Type fc rig !(traverse (desugar side ps') p) mn !(desugarB side ps argTy) !(desugarB side ps' retTy) desugarB side ps (PLam fc rig p pat@(PRef prefFC n@(UN nm)) argTy scope) = if isPatternVariable nm then do whenJust (isConcreteFC prefFC) $ \nfc => addSemanticDecorations [(nfc, Bound, Just n)] - pure $ ILam fc rig !(traverse (desugar AnyExpr ps) p) + pure $ Elaboratable_Lambda fc rig !(traverse (desugar AnyExpr ps) p) (Just n) !(desugarB AnyExpr ps argTy) !(desugar AnyExpr (n :: ps) scope) - else pure $ ILam EmptyFC rig !(traverse (desugar AnyExpr ps) p) + else pure $ Elaboratable_Lambda EmptyFC rig !(traverse (desugar AnyExpr ps) p) (Just (MN "lamc" 0)) !(desugarB AnyExpr ps argTy) $ - ICase fc [] (IVar EmptyFC (MN "lamc" 0)) (Implicit fc False) + Elaboratable_Case fc [] (Elaboratable_Name EmptyFC (MN "lamc" 0)) (Implicit fc False) [snd !(desugarClause ps True (MkPatClause fc pat scope []))] desugarB side ps (PLam fc rig p (PRef _ n@(MN {})) argTy scope) - = pure $ ILam fc rig !(traverse (desugar AnyExpr ps) p) + = pure $ Elaboratable_Lambda fc rig !(traverse (desugar AnyExpr ps) p) (Just n) !(desugarB AnyExpr ps argTy) !(desugar AnyExpr (n :: ps) scope) desugarB side ps (PLam fc rig p (PImplicit _) argTy scope) - = pure $ ILam fc rig !(traverse (desugar AnyExpr ps) p) + = pure $ Elaboratable_Lambda fc rig !(traverse (desugar AnyExpr ps) p) Nothing !(desugarB AnyExpr ps argTy) !(desugar AnyExpr ps scope) desugarB side ps (PLam fc rig p pat argTy scope) - = pure $ ILam EmptyFC rig !(traverse (desugar AnyExpr ps) p) + = pure $ Elaboratable_Lambda EmptyFC rig !(traverse (desugar AnyExpr ps) p) (Just (MN "lamc" 0)) !(desugarB AnyExpr ps argTy) $ - ICase fc [] (IVar EmptyFC (MN "lamc" 0)) (Implicit fc False) + Elaboratable_Case fc [] (Elaboratable_Name EmptyFC (MN "lamc" 0)) (Implicit fc False) [snd !(desugarClause ps True (MkPatClause fc pat scope []))] desugarB side ps (PLet fc rig (PRef prefFC n) nTy nVal scope []) = do whenJust (isConcreteFC prefFC) $ \nfc => addSemanticDecorations [(nfc, Bound, Just n)] - pure $ ILet fc prefFC rig n !(desugarB side ps nTy) !(desugarB side ps nVal) + pure $ Elaboratable_Binding fc prefFC rig n !(desugarB side ps nTy) !(desugarB side ps nVal) !(desugar side (n :: ps) scope) desugarB side ps (PLet fc rig pat nTy nVal scope alts) - = pure $ ICase fc [] !(desugarB side ps nVal) !(desugarB side ps nTy) + = pure $ Elaboratable_Case fc [] !(desugarB side ps nVal) !(desugarB side ps nTy) !(traverse (map snd . desugarClause ps True) (MkPatClause fc pat scope [] :: alts)) desugarB side ps (PCase fc opts scr cls) @@ -371,13 +371,13 @@ mutual scr <- desugarB side ps scr let scrty = Implicit (virtualiseFC fc) False cls <- traverse (map snd . desugarClause ps True) cls - pure $ ICase fc opts scr scrty cls + pure $ Elaboratable_Case fc opts scr scrty cls desugarB side ps (PLocal fc xs scope) = let ps' = definedIn (map val xs) ++ ps in - pure $ ILocal fc (concat !(traverse (desugarDecl ps') xs)) + pure $ Elaboratable_Local_Definitions fc (concat !(traverse (desugarDecl ps') xs)) !(desugar side ps' scope) desugarB side ps (PApp pfc (PUpdate fc fs) rec) - = pure $ IUpdate pfc !(traverse (desugarUpdate side ps) fs) + = pure $ Elaboratable_Record_Update pfc !(traverse (desugarUpdate side ps) fs) !(desugarB side ps rec) desugarB side ps (PUpdate fc fs) = desugarB side ps @@ -385,25 +385,25 @@ mutual PLam vfc top Explicit (PRef vfc (MN "rec" 0)) (PImplicit vfc) $ PApp vfc (PUpdate fc fs) (PRef vfc (MN "rec" 0)) desugarB side ps (PApp fc x y) - = pure $ IApp fc !(desugarB side ps x) !(desugarB side ps y) + = pure $ Elaboratable_Apply fc !(desugarB side ps x) !(desugarB side ps y) desugarB side ps (PAutoApp fc x y) - = pure $ IAutoApp fc !(desugarB side ps x) !(desugarB side ps y) + = pure $ Elaboratable_Automatic_Apply fc !(desugarB side ps x) !(desugarB side ps y) desugarB side ps (PWithApp fc x y) - = pure $ IWithApp fc !(desugarB side ps x) !(desugarB side ps y) + = pure $ Elaboratable_With_Apply fc !(desugarB side ps x) !(desugarB side ps y) desugarB side ps (PNamedApp fc x argn y) - = pure $ INamedApp fc !(desugarB side ps x) argn !(desugarB side ps y) + = pure $ Elaboratable_Named_Apply fc !(desugarB side ps x) argn !(desugarB side ps y) desugarB side ps (PDelayed fc r ty) - = pure $ IDelayed fc r !(desugarB side ps ty) + = pure $ Elaboratable_Delayed_Type fc r !(desugarB side ps ty) desugarB side ps (PDelay fc tm) - = pure $ IDelay fc !(desugarB side ps tm) + = pure $ Elaboratable_Delay fc !(desugarB side ps tm) desugarB side ps (PForce fc tm) - = pure $ IForce fc !(desugarB side ps tm) + = pure $ Elaboratable_Force fc !(desugarB side ps tm) desugarB side ps (PEq fc l r) = do l' <- desugarB side ps l r' <- desugarB side ps r - pure $ IAlternative fc FirstSuccess - [apply (IVar fc (UN $ Basic "===")) [l', r'], - apply (IVar fc (UN $ Basic "~=~")) [l', r']] + pure $ Elaboratable_Alternative fc FirstSuccess + [apply (Elaboratable_Name fc (UN $ Basic "===")) [l', r'], + apply (Elaboratable_Name fc (UN $ Basic "~=~")) [l', r']] desugarB side ps (PBracketed fc e) = desugarB side ps e desugarB side ps (POp fc l op r) = do ts <- toTokList side (POp fc l op r) @@ -429,59 +429,59 @@ mutual = desugarB side ps (PLam fc top Explicit (PRef fc (MN "arg" 0)) (PImplicit fc) (POp fc (MkFCVal op.fc $ NoBinder arg) op (PRef fc (MN "arg" 0)))) - desugarB side ps (PSearch fc depth) = pure $ ISearch fc depth + desugarB side ps (PSearch fc depth) = pure $ Elaboratable_Search fc depth desugarB side ps (PPrimVal fc (BI x)) = case !fromIntegerName of Nothing => - pure $ IAlternative fc (UniqueDefault (IPrimVal fc (BI x))) - [IPrimVal fc (BI x), - IPrimVal fc (I (fromInteger x))] + pure $ Elaboratable_Alternative fc (UniqueDefault (Elaboratable_Primitive_Value fc (BI x))) + [Elaboratable_Primitive_Value fc (BI x), + Elaboratable_Primitive_Value fc (I (fromInteger x))] Just fi => let vfc = virtualiseFC fc in - pure $ IApp vfc (IVar vfc fi) (IPrimVal fc (BI x)) + pure $ Elaboratable_Apply vfc (Elaboratable_Name vfc fi) (Elaboratable_Primitive_Value fc (BI x)) desugarB side ps (PPrimVal fc (Ch x)) = case !fromCharName of Nothing => - pure $ IPrimVal fc (Ch x) + pure $ Elaboratable_Primitive_Value fc (Ch x) Just f => let vfc = virtualiseFC fc in - pure $ IApp vfc (IVar vfc f) (IPrimVal fc (Ch x)) + pure $ Elaboratable_Apply vfc (Elaboratable_Name vfc f) (Elaboratable_Primitive_Value fc (Ch x)) desugarB side ps (PPrimVal fc (Db x)) = case !fromDoubleName of Nothing => - pure $ IPrimVal fc (Db x) + pure $ Elaboratable_Primitive_Value fc (Db x) Just f => let vfc = virtualiseFC fc in - pure $ IApp vfc (IVar vfc f) (IPrimVal fc (Db x)) - desugarB side ps (PPrimVal fc x) = pure $ IPrimVal fc x + pure $ Elaboratable_Apply vfc (Elaboratable_Name vfc f) (Elaboratable_Primitive_Value fc (Db x)) + desugarB side ps (PPrimVal fc x) = pure $ Elaboratable_Primitive_Value fc x desugarB side ps (PQuote fc tm) - = do let q = IQuote fc !(desugarB side ps tm) + = do let q = Elaboratable_Quote fc !(desugarB side ps tm) case side of AnyExpr => pure $ maybeIApp fc !fromTTImpName q _ => pure q desugarB side ps (PQuoteName fc n) - = do let q = IQuoteName fc n + = do let q = Elaboratable_Quote_Name fc n case side of AnyExpr => pure $ maybeIApp fc !fromNameName q _ => pure q desugarB side ps (PQuoteDecl fc x) = do xs <- traverse (desugarDecl ps) x - let dls = IQuoteDecl fc (concat xs) + let dls = Elaboratable_Quote_Declarations fc (concat xs) case side of AnyExpr => pure $ maybeIApp fc !fromDeclsName dls _ => pure dls desugarB side ps (PUnquote fc tm) - = pure $ IUnquote fc !(desugarB side ps tm) + = pure $ Elaboratable_Unquote fc !(desugarB side ps tm) desugarB side ps (PRunElab fc tm) - = pure $ IRunElab fc True !(desugarB side ps tm) + = pure $ Elaboratable_Run_Elaborator fc True !(desugarB side ps tm) desugarB side ps (PHole fc br holename) = do when br $ update Syn { bracketholes $= ((UN (Basic holename)) ::) } - pure $ IHole fc holename - desugarB side ps (PType fc) = pure $ IType fc + pure $ Elaboratable_Hole fc holename + desugarB side ps (PType fc) = pure $ Elaboratable_Type_Universe fc desugarB side ps (PAs fc nameFC vname pattern) - = pure $ IAs fc nameFC UseRight vname !(desugarB side ps pattern) + = pure $ Elaboratable_As_Pattern fc nameFC UseRight vname !(desugarB side ps pattern) desugarB side ps (PDotted fc x) - = pure $ IMustUnify fc UserDotted !(desugarB side ps x) + = pure $ Elaboratable_Must_Unify fc UserDotted !(desugarB side ps x) desugarB side ps (PImplicit fc) = pure $ Implicit fc True desugarB side ps (PInfer fc) = do when (side == LHS) $ @@ -495,10 +495,10 @@ mutual -- are always concatenated with other strings and therefore can never use -- another `fromString` implementation that differs from `id`. desugarB side ps (PString fc hashtag []) - = pure $ maybeIApp fc !fromStringName (IPrimVal fc (Str "")) + = pure $ maybeIApp fc !fromStringName (Elaboratable_Primitive_Value fc (Str "")) desugarB side ps (PString fc hashtag [StrLiteral fc' str]) = case unescape hashtag str of - Just str => pure $ maybeIApp fc !fromStringName (IPrimVal fc' (Str str)) + Just str => pure $ maybeIApp fc !fromStringName (Elaboratable_Primitive_Value fc' (Str str)) Nothing => throw (GenericMsg fc "Invalid escape sequence: \{show str}") desugarB side ps (PString fc hashtag strs) = expandString side ps fc hashtag strs @@ -512,7 +512,7 @@ mutual put Bang ({ nextName $= (+1), bangNames $= ((bn, fc, itm) ::) } bs) - pure (IVar (virtualiseFC fc) bn) + pure (Elaboratable_Name (virtualiseFC fc) bn) desugarB side ps (PIdiom fc ns term) = do itm <- desugarB side ps term logRaw "desugar.idiom" 10 "Desugaring idiom for" itm @@ -526,40 +526,40 @@ mutual desugarB side ps (PPair fc l r) = do l' <- desugarB side ps l r' <- desugarB side ps r - let pval = apply (IVar fc mkpairname) [l', r'] - pure $ IAlternative fc (UniqueDefault pval) - [apply (IVar fc pairname) [l', r'], pval] + let pval = apply (Elaboratable_Name fc mkpairname) [l', r'] + pure $ Elaboratable_Alternative fc (UniqueDefault pval) + [apply (Elaboratable_Name fc pairname) [l', r'], pval] desugarB side ps (PDPair fc opFC (PRef nameFC n@(UN _)) (PImplicit _) r) = do r' <- desugarB side ps r - let pval = apply (IVar opFC mkdpairname) [IVar nameFC n, r'] + let pval = apply (Elaboratable_Name opFC mkdpairname) [Elaboratable_Name nameFC n, r'] let vfc = virtualiseFC nameFC whenJust (isConcreteFC nameFC) $ \nfc => addSemanticDefault (nfc, Bound, Just n) - pure $ IAlternative fc (UniqueDefault pval) - [apply (IVar opFC dpairname) + pure $ Elaboratable_Alternative fc (UniqueDefault pval) + [apply (Elaboratable_Name opFC dpairname) [Implicit vfc False, - ILam nameFC top Explicit (Just n) (Implicit vfc False) r'], + Elaboratable_Lambda nameFC top Explicit (Just n) (Implicit vfc False) r'], pval] desugarB side ps (PDPair fc opFC (PRef namefc n@(UN _)) ty r) = do ty' <- desugarB side ps ty r' <- desugarB side ps r - pure $ apply (IVar opFC dpairname) - [ty', ILam namefc top Explicit (Just n) ty' r'] + pure $ apply (Elaboratable_Name opFC dpairname) + [ty', Elaboratable_Lambda namefc top Explicit (Just n) ty' r'] desugarB side ps (PDPair fc opFC l (PImplicit _) r) = do l' <- desugarB side ps l r' <- desugarB side ps r - pure $ apply (IVar opFC mkdpairname) [l', r'] + pure $ apply (Elaboratable_Name opFC mkdpairname) [l', r'] desugarB side ps (PDPair fc opFC l ty r) = throw (GenericMsg fc "Invalid dependent pair type") desugarB side ps (PUnit fc) - = pure $ IAlternative fc (UniqueDefault (IVar fc (UN $ Basic "MkUnit"))) - [IVar fc (UN $ Basic "Unit"), - IVar fc (UN $ Basic "MkUnit")] + = pure $ Elaboratable_Alternative fc (UniqueDefault (Elaboratable_Name fc (UN $ Basic "MkUnit"))) + [Elaboratable_Name fc (UN $ Basic "Unit"), + Elaboratable_Name fc (UN $ Basic "MkUnit")] desugarB side ps (PIfThenElse fc x t e) = let fc = virtualiseFC fc in - pure $ ICase fc [] !(desugarB side ps x) (IVar fc (UN $ Basic "Bool")) - [PatClause fc (IVar fc (UN $ Basic "True")) !(desugar side ps t), - PatClause fc (IVar fc (UN $ Basic "False")) !(desugar side ps e)] + pure $ Elaboratable_Case fc [] !(desugarB side ps x) (Elaboratable_Name fc (UN $ Basic "Bool")) + [PatClause fc (Elaboratable_Name fc (UN $ Basic "True")) !(desugar side ps t), + PatClause fc (Elaboratable_Name fc (UN $ Basic "False")) !(desugar side ps e)] desugarB side ps (PComprehension fc ret conds) = do let ns = mbNamespace !(get Bang) desugarB side ps (PDoBlock fc ns (map (guard ns) conds ++ [toPure ns ret])) @@ -572,7 +572,7 @@ mutual toPure : Maybe Namespace -> PTerm -> PDo toPure ns tm = DoExp fc (PApp fc (PRef fc (mbApplyNS ns $ UN $ Basic "pure")) tm) desugarB side ps (PRewrite fc rule tm) - = pure $ IRewrite fc !(desugarB side ps rule) !(desugarB side ps tm) + = pure $ Elaboratable_Rewrite fc !(desugarB side ps rule) !(desugarB side ps tm) desugarB side ps (PRange fc start next end) = let fc = virtualiseFC fc in desugarB side ps $ case next of @@ -584,7 +584,7 @@ mutual Nothing => papply fc (PRef fc (UN $ Basic "rangeFrom")) [start] Just n => papply fc (PRef fc (UN $ Basic "rangeFromThen")) [start, n] desugarB side ps (PUnifyLog fc lvl tm) - = pure $ IUnifyLog fc lvl !(desugarB side ps tm) + = pure $ Elaboratable_Unification_Log fc lvl !(desugarB side ps tm) desugarB side ps (PPostfixApp fc rec projs) = desugarB side ps $ foldl (\x, (fc, proj) => PApp fc (PRef fc proj) x) rec projs @@ -595,7 +595,7 @@ mutual PLam fc top Explicit var (PImplicit vfc) $ foldl (\r, (fc, proj) => PApp fc (PRef fc proj) r) var projs desugarB side ps (PWithUnambigNames fc ns rhs) - = IWithUnambigNames fc ns <$> desugarB side ps rhs + = Elaboratable_With_Unambiguous_Names fc ns <$> desugarB side ps rhs desugarUpdate : {auto s : Ref Syn SyntaxInfo} -> {auto b : Ref Bang BangData} -> @@ -603,11 +603,11 @@ mutual {auto u : Ref UST UState} -> {auto m : Ref MD Metadata} -> {auto o : Ref ROpts REPLOpts} -> - Side -> List Name -> PFieldUpdate -> Core IFieldUpdate + Side -> List Name -> PFieldUpdate -> Core Elaboratable_Field_Update desugarUpdate side ps (PSetField p v) - = pure (ISetField p !(desugarB side ps v)) + = pure (Elaboratable_Set_Field p !(desugarB side ps v)) desugarUpdate side ps (PSetFieldApp p v) - = pure (ISetFieldApp p !(desugarB side ps v)) + = pure (Elaboratable_Apply_To_Field p !(desugarB side ps v)) expandList : {auto s : Ref Syn SyntaxInfo} -> {auto b : Ref Bang BangData} -> @@ -617,9 +617,9 @@ mutual {auto o : Ref ROpts REPLOpts} -> Side -> List Name -> (nilFC : FC) -> List (FC, PTerm) -> Core RawImp - expandList side ps nilFC [] = pure (IVar nilFC (UN $ Basic "Nil")) + expandList side ps nilFC [] = pure (Elaboratable_Name nilFC (UN $ Basic "Nil")) expandList side ps nilFC ((consFC, x) :: xs) - = pure $ apply (IVar consFC (UN $ Basic "::")) + = pure $ apply (Elaboratable_Name consFC (UN $ Basic "::")) [!(desugarB side ps x), !(expandList side ps nilFC xs)] expandSnocList @@ -631,9 +631,9 @@ mutual {auto o : Ref ROpts REPLOpts} -> Side -> List Name -> (nilFC : FC) -> SnocList (FC, PTerm) -> Core RawImp - expandSnocList side ps nilFC [<] = pure (IVar nilFC (UN $ Basic "Lin")) + expandSnocList side ps nilFC [<] = pure (Elaboratable_Name nilFC (UN $ Basic "Lin")) expandSnocList side ps nilFC (xs :< (consFC, x)) - = pure $ apply (IVar consFC (UN $ Basic ":<")) + = pure $ apply (Elaboratable_Name consFC (UN $ Basic ":<")) [!(expandSnocList side ps nilFC xs) , !(desugarB side ps x)] maybeIApp : FC -> Maybe Name -> RawImp -> RawImp @@ -642,7 +642,7 @@ mutual Nothing => tm Just f => let fc = virtualiseFC fc in - IApp fc (IVar fc f) tm + Elaboratable_Apply fc (Elaboratable_Name fc f) tm expandString : {auto s : Ref Syn SyntaxInfo} -> {auto b : Ref Bang BangData} -> @@ -654,20 +654,20 @@ mutual expandString side ps fc hashtag xs = do xs <- traverse toRawImp (filter notEmpty $ mergeStrLit xs) pure $ case xs of - [] => IPrimVal fc (Str "") + [] => Elaboratable_Primitive_Value fc (Str "") (_ :: _) => let vfc = virtualiseFC fc in - IApp vfc - (INamedApp vfc - (IVar vfc (NS preludeNS $ UN $ Basic "concat")) + Elaboratable_Apply vfc + (Elaboratable_Named_Apply vfc + (Elaboratable_Name vfc (NS preludeNS $ UN $ Basic "concat")) (UN $ Basic "t") - (IVar vfc (NS preludeNS $ UN $ Basic "List"))) + (Elaboratable_Name vfc (NS preludeNS $ UN $ Basic "List"))) (strInterpolate xs) where toRawImp : PStr -> Core RawImp toRawImp (StrLiteral fc str) = case unescape hashtag str of - Just str => pure $ IPrimVal fc (Str str) + Just str => pure $ Elaboratable_Primitive_Value fc (Str str) Nothing => throw (GenericMsg fc "Invalid escape sequence: \{show str}") toRawImp (StrInterp fc tm) = desugarB side ps tm @@ -688,11 +688,11 @@ mutual strInterpolate : List RawImp -> RawImp strInterpolate [] - = IVar EmptyFC nilName + = Elaboratable_Name EmptyFC nilName strInterpolate (x :: xs) = let xFC = virtualiseFC (getFC x) in - apply (IVar xFC consName) - [ IApp xFC (IVar EmptyFC interpolateName) + apply (Elaboratable_Name xFC consName) + [ Elaboratable_Apply xFC (Elaboratable_Name EmptyFC interpolateName) x , strInterpolate xs ] @@ -764,7 +764,7 @@ mutual (\ty => desugarDo side ps ns ty) ty rest' <- expandDo side ps topfc ns rest pure $ bindFun fc ns tm' - $ ILam nameFC rig Explicit (Just n) ty' rest' + $ Elaboratable_Lambda nameFC rig Explicit (Just n) ty' rest' expandDo side ps topfc ns (DoBindPat fc pat ty exp alts :: rest) = do pat' <- desugarDo LHS ps ns pat (newps, bpat) <- bindNames False pat' @@ -778,9 +778,9 @@ mutual (\ty => desugarDo side ps ns ty) ty rest' <- expandDo side ps' topfc ns rest pure $ bindFun fc ns exp' - $ ILam EmptyFC top Explicit (Just (MN "_" 0)) + $ Elaboratable_Lambda EmptyFC top Explicit (Just (MN "_" 0)) ty' - (ICase fc [] (IVar patFC (MN "_" 0)) + (Elaboratable_Case fc [] (Elaboratable_Name patFC (MN "_" 0)) (Implicit fc False) (PatClause fcOriginal bpat rest' :: alts')) @@ -791,7 +791,7 @@ mutual rest' <- expandDo side ps topfc ns rest whenJust (isConcreteFC lhsFC) $ \nfc => addSemanticDecorations [(nfc, Bound, Just n)] - let bind = ILet fc lhsFC rig n ty' tm' rest' + let bind = Elaboratable_Binding fc lhsFC rig n ty' tm' rest' bd <- get Bang pure $ bindBangs (bangNames bd) ns bind expandDo side ps topfc ns (DoLetPat fc pat ty tm alts :: rest) @@ -806,17 +806,17 @@ mutual bd <- get Bang let fc = virtualiseFC fc pure $ bindBangs (bangNames bd) ns $ - ICase fc [] tm' ty' + Elaboratable_Case fc [] tm' ty' (PatClause fc bpat rest' :: alts') expandDo side ps topfc ns (DoLetLocal fc decls :: rest) = do decls' <- traverse (desugarDecl ps) decls rest' <- expandDo side ps topfc ns rest - pure $ ILocal fc (concat decls') rest' + pure $ Elaboratable_Local_Definitions fc (concat decls') rest' expandDo side ps topfc ns (DoRewrite fc rule :: rest) = do rule' <- desugarDo side ps ns rule rest' <- expandDo side ps topfc ns rest - pure $ IRewrite fc rule' rest' + pure $ Elaboratable_Rewrite fc rule' rest' -- Replace all operator by function application desugarTree : Side -> List Name -> Tree (OpStr, Maybe $ OperatorLHSInfo PTerm) PTerm -> @@ -903,11 +903,11 @@ mutual -- - given the pattern 'f x y', getClauseFn would return 'f'. -- - given the pattern 'x == y', getClausefn would return '=='. getClauseFn : RawImp -> Core Name - getClauseFn (IVar _ n) = pure n - getClauseFn (IApp _ f _) = getClauseFn f - getClauseFn (IWithApp _ f _) = getClauseFn f - getClauseFn (IAutoApp _ f _) = getClauseFn f - getClauseFn (INamedApp _ f _ _) = getClauseFn f + getClauseFn (Elaboratable_Name _ n) = pure n + getClauseFn (Elaboratable_Apply _ f _) = getClauseFn f + getClauseFn (Elaboratable_With_Apply _ f _) = getClauseFn f + getClauseFn (Elaboratable_Automatic_Apply _ f _) = getClauseFn f + getClauseFn (Elaboratable_Named_Apply _ f _ _) = getClauseFn f getClauseFn tm = throw $ GenericMsg (getFC tm) "Head term in pattern must be a function name" desugarLHS : {auto s : Ref Syn SyntaxInfo} -> @@ -962,7 +962,7 @@ mutual rhs' <- desugar AnyExpr (bound ++ ps) rhs let rhs' = case ws of [] => rhs' - _ => ILocal fc (concat ws) rhs' + _ => Elaboratable_Local_Definitions fc (concat ws) rhs' pure (nm, PatClause fc lhs' rhs') @@ -1007,7 +1007,7 @@ mutual {auto m : Ref MD Metadata} -> {auto o : Ref ROpts REPLOpts} -> List Name -> Namespace -> PField -> - Core (List IField) + Core (List Elaboratable_Field) desugarField ps ns field = flip Core.traverse field.names $ \n : WithFC Name => do addDocStringNS ns n.val field.doc @@ -1101,7 +1101,7 @@ mutual types <- desugarType ps ty pure $ flip (map {f = List, b = ImpDecl}) types $ \ty' => - IClaim (MkFCVal claim.fc $ MkIClaimData rig vis opts ty') + Elaboratable_Claim (MkFCVal claim.fc $ Make_Elaboratable_Claim_Data rig vis opts ty') desugarDecl ps (MkWithData fc (PDef clauses)) -- The clauses won't necessarily all be from the same function, so split @@ -1112,14 +1112,14 @@ mutual where toIDef : Name -> ImpClause -> Core ImpDecl toIDef nm (PatClause fc lhs rhs) - = pure $ IDef fc nm [PatClause fc lhs rhs] + = pure $ Elaboratable_Definition fc nm [PatClause fc lhs rhs] toIDef nm (WithClause fc lhs rig rhs prf flags cs) - = pure $ IDef fc nm [WithClause fc lhs rig rhs prf flags cs] + = pure $ Elaboratable_Definition fc nm [WithClause fc lhs rig rhs prf flags cs] toIDef nm (ImpossibleClause fc lhs) - = pure $ IDef fc nm [ImpossibleClause fc lhs] + = pure $ Elaboratable_Definition fc nm [ImpossibleClause fc lhs] desugarDecl ps dat@(MkWithData _ $ PData doc vis mbtot ddecl) - = pure [IData dat.fc vis mbtot !(desugarData ps doc ddecl)] + = pure [Elaboratable_Data_Declaration dat.fc vis mbtot !(desugarData ps doc ddecl)] desugarDecl ps pp@(MkWithData _ $ PParameters params pds) = do @@ -1134,7 +1134,7 @@ mutual $ findUniqueBindableNames pp.fc True (ps ++ paramNames) [] let paramsb = map {f = List1} (map {f = WithData _} (mapType (doBind pnames))) params' - pure [IParameters pp.fc paramsb (concat pds')] + pure [Elaboratable_Parameter_Block pp.fc paramsb (concat pds')] where getArgs : Either (List1 PlainBinder) (List1 PBinder) -> @@ -1186,7 +1186,7 @@ mutual let consb = map (\ (nm, tm) => (nm, doBind bnames tm)) cons' body' <- traverse (desugarDecl (ps ++ mnames ++ paramNames)) body - pure [IPragma int.fc (maybe [tn] (\n => [tn, n.val]) conname) + pure [Elaboratable_Pragma int.fc (maybe [tn] (\n => [tn, n.val]) conname) (\nest, env => elabInterface int.fc vis env nest consb tn paramsb det conname @@ -1233,7 +1233,7 @@ mutual -- given. let impname = maybe (mkImplName impl.fc tn paramsb) id impln - pure [IPragma impl.fc [impname] + pure [Elaboratable_Pragma impl.fc [impname] (\nest, env => elabImplementation impl.fc vis opts pass env nest isb consb tn paramsb (isNamed impln) @@ -1273,11 +1273,11 @@ mutual let paramsb : List ImpParameter = map (map $ mapType $ doBind bnames) params' let recName = nameRoot tn - fields' : List (List IField) <- for fields (desugarField (ps ++ fnames ++ paramNames) + fields' : List (List Elaboratable_Field) <- for fields (desugarField (ps ++ fnames ++ paramNames) (mkNamespace recName)) let conname : Name = maybe (mkConName tn) val conname_in whenJust (get "doc" <$> conname_in) (addDocString conname) - pure [IRecord rec.fc (Just recName) + pure [Elaboratable_Record_Declaration rec.fc (Just recName) vis mbtot (Mk [rec.fc] $ MkImpRecord (Mk [NoFC tn] paramsb) (Mk [NoFC conname, opts] (concat fields')))] where getfname : PField -> List Name @@ -1359,7 +1359,7 @@ mutual put Ctxt defs -- either fail or return the block that should fail during the elab phase case the (Either (Maybe Error) (List ImpDecl)) result of - Right ds => [IFail d.fc mmsg ds] <$ log "desugar.failing" 20 "Success" + Right ds => [Elaboratable_Expected_Failure d.fc mmsg ds] <$ log "desugar.failing" 20 "Success" Left Nothing => [] <$ log "desugar.failing" 20 "Correctly failed" Left (Just err) => throw err desugarDecl ps (MkWithData _ $ PMutual ds) @@ -1369,49 +1369,49 @@ mutual desugarDecl ps n@(MkWithData _ $ PNamespace ns decls) = withExtendedNS ns $ do ds <- traverse (desugarDecl ps) decls - pure [INamespace n.fc ns (concat ds)] + pure [Elaboratable_Namespace_Block n.fc ns (concat ds)] desugarDecl ps ts@(MkWithData _ $ PTransform n lhs rhs) = do (bound, blhs) <- bindNames False !(desugar LHS ps lhs) rhs' <- desugar AnyExpr (bound ++ ps) rhs - pure [ITransform ts.fc (UN $ Basic n) blhs rhs'] + pure [Elaboratable_Transformation ts.fc (UN $ Basic n) blhs rhs'] desugarDecl ps el@(MkWithData _ $ PRunElabDecl tm) = do tm' <- desugar AnyExpr ps tm - pure [IRunElabDecl el.fc tm'] + pure [Elaboratable_Run_Elaborator_Declaration el.fc tm'] desugarDecl ps dir@(MkWithData _ $ PDirective d) = let fc = dir.fc in case d of - Hide (HideName n) => pure [IPragma fc [] (\nest, env => hide fc n)] - Hide (HideFixity fx n) => pure [IPragma fc [] (\_, _ => removeFixity fc fx n)] - Unhide n => pure [IPragma fc [] (\nest, env => unhide fc n)] - Logging i => pure [ILog ((\ i => (topics i, verbosity i)) <$> i)] - LazyOn a => pure [IPragma fc [] (\nest, env => lazyActive a)] + Hide (HideName n) => pure [Elaboratable_Pragma fc [] (\nest, env => hide fc n)] + Hide (HideFixity fx n) => pure [Elaboratable_Pragma fc [] (\_, _ => removeFixity fc fx n)] + Unhide n => pure [Elaboratable_Pragma fc [] (\nest, env => unhide fc n)] + Logging i => pure [Elaboratable_Logging ((\ i => (topics i, verbosity i)) <$> i)] + LazyOn a => pure [Elaboratable_Pragma fc [] (\nest, env => lazyActive a)] UnboundImplicits a => do setUnboundImplicits a - pure [IPragma fc [] (\nest, env => setUnboundImplicits a)] + pure [Elaboratable_Pragma fc [] (\nest, env => setUnboundImplicits a)] PrefixRecordProjections b => do - pure [IPragma fc [] (\nest, env => setPrefixRecordProjections b)] - AmbigDepth n => pure [IPragma fc [] (\nest, env => setAmbigLimit n)] - TotalityDepth n => pure [IPragma fc [] (\next, env => setTotalLimit n)] - AutoImplicitDepth n => pure [IPragma fc [] (\nest, env => setAutoImplicitLimit n)] - NFMetavarThreshold n => pure [IPragma fc [] (\nest, env => setNFThreshold n)] - SearchTimeout n => pure [IPragma fc [] (\nest, env => setSearchTimeout n)] - PairNames ty f s => pure [IPragma fc [] (\nest, env => setPair fc ty f s)] - RewriteName eq rw => pure [IPragma fc [] (\nest, env => setRewrite fc eq rw)] - PrimInteger n => pure [IPragma fc [] (\nest, env => setFromInteger n)] - PrimString n => pure [IPragma fc [] (\nest, env => setFromString n)] - PrimChar n => pure [IPragma fc [] (\nest, env => setFromChar n)] - PrimDouble n => pure [IPragma fc [] (\nest, env => setFromDouble n)] - PrimTTImp n => pure [IPragma fc [] (\nest, env => setFromTTImp n)] - PrimName n => pure [IPragma fc [] (\nest, env => setFromName n)] - PrimDecls n => pure [IPragma fc [] (\nest, env => setFromDecls n)] - CGAction cg dir => pure [IPragma fc [] (\nest, env => addDirective cg dir)] - Names n ns => pure [IPragma fc [] (\nest, env => addNameDirective fc n ns)] - StartExpr tm => pure [IPragma fc [] (\nest, env => throw (InternalError "%start not implemented"))] -- TODO! - Overloadable n => pure [IPragma fc [] (\nest, env => setNameFlag fc n Overloadable)] - Extension e => pure [IPragma fc [] (\nest, env => setExtension e)] - DefaultTotality tot => pure [IPragma fc [] (\_, _ => setDefaultTotalityOption tot)] + pure [Elaboratable_Pragma fc [] (\nest, env => setPrefixRecordProjections b)] + AmbigDepth n => pure [Elaboratable_Pragma fc [] (\nest, env => setAmbigLimit n)] + TotalityDepth n => pure [Elaboratable_Pragma fc [] (\next, env => setTotalLimit n)] + AutoImplicitDepth n => pure [Elaboratable_Pragma fc [] (\nest, env => setAutoImplicitLimit n)] + NFMetavarThreshold n => pure [Elaboratable_Pragma fc [] (\nest, env => setNFThreshold n)] + SearchTimeout n => pure [Elaboratable_Pragma fc [] (\nest, env => setSearchTimeout n)] + PairNames ty f s => pure [Elaboratable_Pragma fc [] (\nest, env => setPair fc ty f s)] + RewriteName eq rw => pure [Elaboratable_Pragma fc [] (\nest, env => setRewrite fc eq rw)] + PrimInteger n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromInteger n)] + PrimString n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromString n)] + PrimChar n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromChar n)] + PrimDouble n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromDouble n)] + PrimTTImp n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromTTImp n)] + PrimName n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromName n)] + PrimDecls n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromDecls n)] + CGAction cg dir => pure [Elaboratable_Pragma fc [] (\nest, env => addDirective cg dir)] + Names n ns => pure [Elaboratable_Pragma fc [] (\nest, env => addNameDirective fc n ns)] + StartExpr tm => pure [Elaboratable_Pragma fc [] (\nest, env => throw (InternalError "%start not implemented"))] -- TODO! + Overloadable n => pure [Elaboratable_Pragma fc [] (\nest, env => setNameFlag fc n Overloadable)] + Extension e => pure [Elaboratable_Pragma fc [] (\nest, env => setExtension e)] + DefaultTotality tot => pure [Elaboratable_Pragma fc [] (\_, _ => setDefaultTotalityOption tot)] ForeignImpl n cs => do cs' <- traverse (desugar AnyExpr ps) cs - pure [IPragma fc [] (\nest, env => do + pure [Elaboratable_Pragma fc [] (\nest, env => do defs <- get Ctxt calls <- traverse getFnString cs' [(n',_,gdef)] <- lookupCtxtName n (gamma defs) @@ -1422,7 +1422,7 @@ mutual update Ctxt { options->foreignImpl $= (map (n',) calls ++) } )] - desugarDecl ps bt@(MkWithData _ $ PBuiltin type name) = pure [IBuiltin bt.fc type name] + desugarDecl ps bt@(MkWithData _ $ PBuiltin type name) = pure [Elaboratable_Builtin_Declaration bt.fc type name] export desugarDo : {auto s : Ref Syn SyntaxInfo} -> diff --git a/Idris/Elab/Implementation.idr b/Idris/Elab/Implementation.idr index e8f5b0e44a..b45d391831 100644 --- a/Idris/Elab/Implementation.idr +++ b/Idris/Elab/Implementation.idr @@ -44,12 +44,12 @@ bindConstraints : FC -> PiInfo RawImp -> List (Maybe Name, RawImp) -> RawImp -> RawImp bindConstraints fc p [] ty = ty bindConstraints fc p ((n, ty) :: rest) sc - = IPi fc top p n ty (bindConstraints fc p rest sc) + = Elaboratable_Dependent_Function_Type fc top p n ty (bindConstraints fc p rest sc) bindImpls : List (AddFC (ImpParameter' RawImp)) -> RawImp -> RawImp bindImpls [] ty = ty bindImpls (binder :: rest) sc - = IPi binder.fc binder.rig binder.val.info (Just binder.nameVal) binder.val.boundType (bindImpls rest sc) + = Elaboratable_Dependent_Function_Type binder.fc binder.rig binder.val.info (Just binder.nameVal) binder.val.boundType (bindImpls rest sc) addDefaults : FC -> Name -> (params : List (Name, RawImp)) -> -- parameters have been specialised, use them! @@ -62,7 +62,7 @@ addDefaults fc impName params allms defs body extendBody [] missing body where specialiseMeth : Name -> (Name, RawImp) - specialiseMeth n = (n, INamedApp fc (IVar fc n) constructorBindName (IVar fc impName)) + specialiseMeth n = (n, Elaboratable_Named_Apply fc (Elaboratable_Name fc n) constructorBindName (Elaboratable_Name fc impName)) -- Given the list of missing names, if any are among the default definitions, -- add them to the body extendBody : List Name -> List Name -> List ImpDecl -> @@ -86,12 +86,12 @@ addDefaults fc impName params allms defs body let mupdates = params ++ map specialiseMeth allms cs' = map (substNamesClause [] mupdates) cs in extendBody ms ns - (IDef fc n (map (substLocClause fc) cs') :: body) + (Elaboratable_Definition fc n (map (substLocClause fc) cs') :: body) -- Find which names are missing from the body dropGot : List Name -> List ImpDecl -> List Name dropGot ms [] = ms - dropGot ms (IDef _ n _ :: ds) + dropGot ms (Elaboratable_Definition _ n _ :: ds) = dropGot (filter (/= n) ms) ds dropGot ms (_ :: ds) = dropGot ms ds @@ -151,8 +151,8 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i Just conty <- lookupTyExact (iconstructor cdata) (gamma defs) | Nothing => undefinedName vfc (iconstructor cdata) - let impsp = nub (concatMap findIBinds ps ++ - concatMap findIBinds (map snd cons)) + let impsp = nub (concatMap find_names_to_bind ps ++ + concatMap find_names_to_bind (map snd cons)) logTerm "elab.implementation" 3 ("Found interface " ++ show cn) ity log "elab.implementation" 3 $ @@ -175,14 +175,14 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i else [Inline, Hint True] let initTy = bindImpls is $ bindConstraints vfc AutoImplicit cons - (apply (IVar vfc iname) ps) + (apply (Elaboratable_Name vfc iname) ps) let paramBinds = if !isUnboundImplicits then findBindableNames True varsList [] initTy else [] let impTy = doBind paramBinds initTy let impTyDecl - = IClaim (MkFCVal vfc $ MkIClaimData top vis opts (Mk [EmptyFC, NoFC impName] impTy)) + = Elaboratable_Claim (MkFCVal vfc $ Make_Elaboratable_Claim_Data top vis opts (Mk [EmptyFC, NoFC impName] impTy)) log "elab.implementation" 5 $ "Implementation type: " ++ show impTy @@ -198,7 +198,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i let None = definition gdef | _ => throw (AlreadyDefined vfc impName) (ty,_) <- elabTerm tidx InType [] nest env - (IBindHere vfc (PI erased) impTy) + (Elaboratable_Bind_Here vfc (PI erased) impTy) (Just (gType vfc u)) let fullty = abstractFullEnvType vfc env ty ok <- convert defs Env.empty fullty (type gdef) @@ -247,16 +247,16 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i -- 3. Build the record for the implementation let mtops = map (fst . snd) fns let con = iconstructor cdata - let ilhs = impsApply (IVar EmptyFC impName) - (map (\(x, _) => (x, IBindVar vfc x)) methImps) + let ilhs = impsApply (Elaboratable_Name EmptyFC impName) + (map (\(x, _) => (x, Elaboratable_Bind_Name vfc x)) methImps) -- RHS is the constructor applied to a search for the necessary -- parent constraints, then the method implementations defs <- get Ctxt let fldTys = getFieldArgs !(normaliseHoles defs Env.empty conty) log "elab.implementation" 5 $ "Field types " ++ show fldTys - let irhs = apply (autoImpsApply (IVar vfc con) $ map (const (ISearch vfc 500)) (parents cdata)) + let irhs = apply (autoImpsApply (Elaboratable_Name vfc con) $ map (const (Elaboratable_Search vfc 500)) (parents cdata)) (map (mkMethField methImps fldTys) fns) - let impFn = IDef vfc impName [PatClause vfc ilhs irhs] + let impFn = Elaboratable_Definition vfc impName [PatClause vfc ilhs irhs] log "elab.implementation" 5 $ "Implementation record: " ++ show impFn -- If it's a named implementation, add it as a global hint while @@ -326,27 +326,27 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i impsApply : RawImp -> List (Name, RawImp) -> RawImp impsApply fn [] = fn impsApply fn ((n, arg) :: ns) - = impsApply (INamedApp vfc fn n arg) ns + = impsApply (Elaboratable_Named_Apply vfc fn n arg) ns autoImpsApply : RawImp -> List RawImp -> RawImp autoImpsApply f [] = f - autoImpsApply f (x :: xs) = autoImpsApply (IAutoApp (getFC f) f x) xs + autoImpsApply f (x :: xs) = autoImpsApply (Elaboratable_Automatic_Apply (getFC f) f x) xs mkLam : List (Name, RigCount, PiInfo RawImp) -> RawImp -> RawImp mkLam [] tm = tm mkLam ((x, c, p) :: xs) tm - = ILam EmptyFC c p (Just x) (Implicit vfc False) (mkLam xs tm) + = Elaboratable_Lambda EmptyFC c p (Just x) (Implicit vfc False) (mkLam xs tm) applyTo : RawImp -> List (Name, RigCount, PiInfo RawImp) -> RawImp applyTo tm [] = tm applyTo tm ((x, c, Explicit) :: xs) - = applyTo (IApp EmptyFC tm (IVar EmptyFC x)) xs + = applyTo (Elaboratable_Apply EmptyFC tm (Elaboratable_Name EmptyFC x)) xs applyTo tm ((x, c, AutoImplicit) :: xs) - = applyTo (INamedApp EmptyFC tm x (IVar EmptyFC x)) xs + = applyTo (Elaboratable_Named_Apply EmptyFC tm x (Elaboratable_Name EmptyFC x)) xs applyTo tm ((x, c, Implicit) :: xs) - = applyTo (INamedApp EmptyFC tm x (IVar EmptyFC x)) xs + = applyTo (Elaboratable_Named_Apply EmptyFC tm x (Elaboratable_Name EmptyFC x)) xs applyTo tm ((x, c, DefImplicit _) :: xs) - = applyTo (INamedApp EmptyFC tm x (IVar EmptyFC x)) xs + = applyTo (Elaboratable_Named_Apply EmptyFC tm x (Elaboratable_Name EmptyFC x)) xs -- When applying the method in the field for the record, eta expand -- the expected arguments based on the field type, so that implicits get @@ -361,8 +361,8 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i -- implicit arguments to the declaration mkLam argns (impsApply - (applyTo (IVar EmptyFC n) argns) - (map (\n => (n, IVar vfc n)) imps)) + (applyTo (Elaboratable_Name EmptyFC n) argns) + (map (\n => (n, Elaboratable_Name vfc n)) imps)) where applyUpdate : (Name, RigCount, PiInfo RawImp) -> (Name, RigCount, PiInfo RawImp) @@ -381,14 +381,14 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i applyCon : Name -> Name -> Core (Name, RawImp) applyCon impl n = do mn <- inCurrentNS (methName n) - pure (dropNS n, IVar vfc mn) + pure (dropNS n, Elaboratable_Name vfc mn) bindImps : List (Name, RigCount, Maybe RawImp, RawImp) -> RawImp -> RawImp bindImps [] ty = ty bindImps ((n, c, Just def, t) :: ts) ty - = IPi vfc c (DefImplicit def) (Just n) t (bindImps ts ty) + = Elaboratable_Dependent_Function_Type vfc c (DefImplicit def) (Just n) t (bindImps ts ty) bindImps ((n, c, Nothing, t) :: ts) ty - = IPi vfc c Implicit (Just n) t (bindImps ts ty) + = Elaboratable_Dependent_Function_Type vfc c Implicit (Just n) t (bindImps ts ty) -- Return method name, specialised method name, implicit name updates, -- and method type. Also return how the method name should be updated @@ -447,8 +447,8 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i log "elab.implementation" 10 $ "Used names " ++ show ibound let ibinds = map fst methImps let methupds' = if isNil ibinds then [] - else [(n, impsApply (IVar vfc n) - (map (\x => (x, IBindVar vfc x)) ibinds))] + else [(n, impsApply (Elaboratable_Name vfc n) + (map (\x => (x, Elaboratable_Bind_Name vfc x)) ibinds))] pure ((meth.nameVal, n, upds, meth.rig, meth.totReq, mty), methupds') @@ -469,7 +469,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i = do let opts = if isJust $ findTotality opts_in then opts_in else maybe opts_in (\t => Totality t :: opts_in) treq - IClaim $ MkFCVal vfc $ MkIClaimData c vis opts $ Mk [EmptyFC, NoFC n] mty + Elaboratable_Claim $ MkFCVal vfc $ Make_Elaboratable_Claim_Data c vis opts $ Mk [EmptyFC, NoFC n] mty -- Given the method type (result of topMethType) return the mapping from -- top level method name to current implementation's method name @@ -488,21 +488,21 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i Just n' => pure n' updateApp : List (Name, Name) -> RawImp -> Core RawImp - updateApp ns (IVar fc n) + updateApp ns (Elaboratable_Name fc n) = do n' <- findMethName ns fc n - pure (IVar fc n') - updateApp ns (IApp fc f arg) + pure (Elaboratable_Name fc n') + updateApp ns (Elaboratable_Apply fc f arg) = do f' <- updateApp ns f - pure (IApp fc f' arg) - updateApp ns (IWithApp fc f arg) + pure (Elaboratable_Apply fc f' arg) + updateApp ns (Elaboratable_With_Apply fc f arg) = do f' <- updateApp ns f - pure (IWithApp fc f' arg) - updateApp ns (IAutoApp fc f arg) + pure (Elaboratable_With_Apply fc f' arg) + updateApp ns (Elaboratable_Automatic_Apply fc f arg) = do f' <- updateApp ns f - pure (IAutoApp fc f' arg) - updateApp ns (INamedApp fc f x arg) + pure (Elaboratable_Automatic_Apply fc f' arg) + updateApp ns (Elaboratable_Named_Apply fc f x arg) = do f' <- updateApp ns f - pure (INamedApp fc f' x arg) + pure (Elaboratable_Named_Apply fc f' x arg) updateApp ns tm = throw (GenericMsg (getFC tm) "Invalid method definition") @@ -520,11 +520,11 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i pure (ImpossibleClause fc lhs') updateBody : List (Name, Name) -> ImpDecl -> Core ImpDecl - updateBody ns (IDef fc n cs) + updateBody ns (Elaboratable_Definition fc n cs) = do cs' <- traverse (updateClause ns) cs n' <- findMethName ns fc n log "ide-mode.highlight" 1 $ show (n, n', fc) - pure (IDef fc n' cs') + pure (Elaboratable_Definition fc n' cs') updateBody ns e = throw (GenericMsg (getFC e) "Implementation body can only contain definitions") @@ -536,16 +536,16 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i = do log "elab.implementation" 3 $ "Adding transform for " ++ show meth.nameVal ++ " : " ++ show meth.val ++ "\n\tfor " ++ show iname ++ " in " ++ show ns - let lhs = INamedApp vfc (IVar vfc meth.name.val) + let lhs = Elaboratable_Named_Apply vfc (Elaboratable_Name vfc meth.name.val) constructorBindName - (IVar vfc iname) + (Elaboratable_Name vfc iname) let Just mname = lookup (dropNS meth.nameVal) ns | Nothing => pure () - let rhs = IVar vfc mname + let rhs = Elaboratable_Name vfc mname log "elab.implementation" 5 $ show lhs ++ " ==> " ++ show rhs handleUnify (processDecl [] nest env - (ITransform vfc (UN $ Basic (show meth.nameVal ++ " " ++ show iname)) lhs rhs)) + (Elaboratable_Transformation vfc (UN $ Basic (show meth.nameVal ++ " " ++ show iname)) lhs rhs)) (\err => log "elab.implementation" 5 $ "Can't add transform " ++ show lhs ++ " ==> " ++ show rhs ++ diff --git a/Idris/Elab/Interface.idr b/Idris/Elab/Interface.idr index 6436ac5727..7046fef731 100644 --- a/Idris/Elab/Interface.idr +++ b/Idris/Elab/Interface.idr @@ -37,26 +37,26 @@ constructorBindName = UN (Basic "__con") -- Give implicit Pi bindings explicit names, if they don't have one already, -- because we need them to be consistent everywhere we refer to them namePis : Int -> RawImp -> RawImp -namePis i (IPi fc r info n ty sc) +namePis i (Elaboratable_Dependent_Function_Type fc r info n ty sc) = let (n', i') = if isImplicit info && isUnnamed n then (Just (MN "i_con" i), i + 1) else (n, i) - in IPi fc r info n' ty (namePis i' sc) + in Elaboratable_Dependent_Function_Type fc r info n' ty (namePis i' sc) where isUnnamed : Maybe Name -> Bool isUnnamed = maybe True isUnderscoreName -namePis i (IBindHere fc m ty) = IBindHere fc m (namePis i ty) +namePis i (Elaboratable_Bind_Here fc m ty) = Elaboratable_Bind_Here fc m (namePis i ty) namePis i ty = ty getSig : ImpDecl -> Maybe Signature -getSig (IClaim (MkWithData _ $ MkIClaimData c _ opts ty)) +getSig (Elaboratable_Claim (MkWithData _ $ Make_Elaboratable_Claim_Data c _ opts ty)) = Just $ MkSignature { count = c , flags = opts , name = ty.tyName , isData = False , type = namePis 0 ty.val } -getSig (IData _ _ _ (MkImpLater fc n ty)) +getSig (Elaboratable_Data_Declaration _ _ _ (MkImpLater fc n ty)) = Just $ MkSignature { count = erased , flags = [Invertible] , name = NoFC n @@ -72,9 +72,9 @@ getSig _ = Nothing -- TODO: Deal with default superclass implementations mkDataTy : FC -> List (Name, (RigCount, RawImp)) -> RawImp -mkDataTy fc [] = IType fc +mkDataTy fc [] = Elaboratable_Type_Universe fc mkDataTy fc ((n, (_, ty)) :: ps) - = IPi fc top Explicit (Just n) ty (mkDataTy fc ps) + = Elaboratable_Dependent_Function_Type fc top Explicit (Just n) ty (mkDataTy fc ps) jname : (Name, (RigCount, RawImp)) -> (Maybe Name, RigCount, RawImp) jname (n, rig, t) = (Just n, rig, t) @@ -83,7 +83,7 @@ mkTy : FC -> PiInfo RawImp -> List (Maybe Name, RigCount, RawImp) -> RawImp -> RawImp mkTy fc imp [] ret = ret mkTy fc imp ((n, c, argty) :: args) ret - = IPi fc c imp n argty (mkTy fc imp args ret) + = Elaboratable_Dependent_Function_Type fc c imp n argty (mkTy fc imp args ret) mkIfaceData : {vars : _} -> {auto c : Ref Ctxt Defs} -> @@ -95,14 +95,14 @@ mkIfaceData {vars} ifc def_vis env constraints n conName ps dets meths = let opts = [NoHints, UniqueSearch] ++ maybe [] (singleton . SearchBy) dets pNames = map fst ps - retty = apply (IVar vfc n) (map (IVar EmptyFC) pNames) + retty = apply (Elaboratable_Name vfc n) (map (Elaboratable_Name EmptyFC) pNames) conty = mkTy vfc Implicit (map jname ps) $ mkTy vfc AutoImplicit (map bhere constraints) $ mkTy vfc Explicit (map bname meths) retty con = Mk [vfc, NoFC conName] !(bindTypeNames ifc [] (pNames ++ map fst meths ++ toList vars) conty) bound = pNames ++ map fst meths ++ toList vars in - pure $ IData vfc def_vis Nothing {- ?? -} + pure $ Elaboratable_Data_Declaration vfc def_vis Nothing {- ?? -} $ MkImpData vfc n (Just !(bindTypeNames ifc [] bound (mkDataTy vfc ps))) opts [con] @@ -111,10 +111,10 @@ mkIfaceData {vars} ifc def_vis env constraints n conName ps dets meths vfc = virtualiseFC ifc bname : (Name, RigCount, RawImp) -> (Maybe Name, RigCount, RawImp) - bname (n, c, t) = (Just n, c, IBindHere (getFC t) (PI erased) t) + bname (n, c, t) = (Just n, c, Elaboratable_Bind_Here (getFC t) (PI erased) t) bhere : (Maybe Name, RigCount, RawImp) -> (Maybe Name, RigCount, RawImp) - bhere (n, c, t) = (n, c, IBindHere (getFC t) (PI erased) t) + bhere (n, c, t) = (n, c, Elaboratable_Bind_Here (getFC t) (PI erased) t) -- Get the implicit arguments for a method declaration or constraint hint -- to allow us to build the data declaration @@ -134,16 +134,16 @@ getMethDecl {vars} env nest params mnames (c, nm, ty) -- type in the record for the interface (they are parameters of the -- interface type), so remove it here stripParams : List Name -> RawImp -> RawImp - stripParams ps (IPi fc r p mn arg ret) + stripParams ps (Elaboratable_Dependent_Function_Type fc r p mn arg ret) = if (maybe False (\n => n `elem` ps) mn) then stripParams ps ret - else IPi fc r p mn arg (stripParams ps ret) + else Elaboratable_Dependent_Function_Type fc r p mn arg (stripParams ps ret) stripParams ps ty = ty -- bind the auto implicit for the interface - put it first, as it may be needed -- in other method variables, including implicit variables bindIFace : FC -> RawImp -> RawImp -> RawImp -bindIFace fc ity sc = IPi fc top AutoImplicit (Just constructorBindName) ity sc +bindIFace fc ity sc = Elaboratable_Dependent_Function_Type fc top AutoImplicit (Just constructorBindName) ity sc -- Get the top level function for implementing a method getMethToplevel : {vars : _} -> @@ -158,23 +158,23 @@ getMethToplevel : {vars : _} -> Core (List ImpDecl) getMethToplevel {vars} env vis iname cname allmeths bindNames params (mname, sig) = do let paramNames = map fst params - let ity = apply (IVar vfc iname) (map (IVar EmptyFC) paramNames) + let ity = apply (Elaboratable_Name vfc iname) (map (Elaboratable_Name EmptyFC) paramNames) -- Make the constraint application explicit for any method names -- which appear in other method types let ty_constr = substNames (toList vars) (map applyCon allmeths) sig.type ty_imp <- bindTypeNames EmptyFC [] (toList vars) (bindPs params $ bindIFace vfc ity ty_constr) cn <- traverse inCurrentNS sig.name - let tydecl = IClaim (MkFCVal vfc $ MkIClaimData sig.count vis (if sig.isData then [Inline, Invertible] + let tydecl = Elaboratable_Claim (MkFCVal vfc $ Make_Elaboratable_Claim_Data sig.count vis (if sig.isData then [Inline, Invertible] else [Inline]) (Mk [vfc, cn] ty_imp)) - let conapp = apply (IVar vfc cname) (map (IBindVar EmptyFC) bindNames) + let conapp = apply (Elaboratable_Name vfc cname) (map (Elaboratable_Bind_Name EmptyFC) bindNames) - let lhs = INamedApp vfc - (IVar cn.fc cn.val) -- See #3409 + let lhs = Elaboratable_Named_Apply vfc + (Elaboratable_Name cn.fc cn.val) -- See #3409 constructorBindName conapp - let rhs = IVar EmptyFC mname + let rhs = Elaboratable_Name EmptyFC mname -- EtaExpand implicits on both sides: -- First, obtain all the implicit names in the prefix of @@ -182,7 +182,7 @@ getMethToplevel {vars} env vis iname cname allmeths bindNames params (mname, sig (lhs, rhs) <- etaExpandImplicits vfc sig.type lhs rhs let fnclause = PatClause vfc lhs rhs - let fndef = IDef vfc cn.val [fnclause] + let fndef = Elaboratable_Definition vfc cn.val [fnclause] pure [tydecl, fndef] where vfc : FC @@ -193,11 +193,11 @@ getMethToplevel {vars} env vis iname cname allmeths bindNames params (mname, sig bindPs : List (Name, (RigCount, RawImp)) -> RawImp -> RawImp bindPs [] ty = ty bindPs ((n, rig, pty) :: ps) ty - = IPi (getFC pty) rig Implicit (Just n) pty (bindPs ps ty) + = Elaboratable_Dependent_Function_Type (getFC pty) rig Implicit (Just n) pty (bindPs ps ty) applyCon : Name -> (Name, RawImp) applyCon n - = (n, INamedApp vfc (IVar vfc n) constructorBindName (IVar vfc constructorBindName)) + = (n, Elaboratable_Named_Apply vfc (Elaboratable_Name vfc n) constructorBindName (Elaboratable_Name vfc constructorBindName)) -- Get the function for chasing a constraint. This is one of the -- arguments to the record, appearing before the method arguments. @@ -211,33 +211,33 @@ getConstraintHint : {vars : _} -> (Name, RawImp) -> Core (Name, List ImpDecl) getConstraintHint {vars} fc env vis iname cname constraints meths params (cn, con) = do let pNames = map fst params - let ity = apply (IVar fc iname) (map (IVar fc) pNames) + let ity = apply (Elaboratable_Name fc iname) (map (Elaboratable_Name fc) pNames) let fty = mkTy fc Implicit (map jname params) $ mkTy fc Explicit [(Nothing, top, ity)] con ty_imp <- bindTypeNames fc [] (pNames ++ meths ++ toList vars) fty let hintname = DN ("Constraint " ++ show con) (UN (Basic $ "__" ++ show iname ++ "_" ++ show con)) - let tydecl = IClaim (MkFCVal fc $ MkIClaimData top vis [Inline, Hint False] + let tydecl = Elaboratable_Claim (MkFCVal fc $ Make_Elaboratable_Claim_Data top vis [Inline, Hint False] (Mk [EmptyFC, NoFC hintname] ty_imp)) - let conapp = apply (impsBind (IVar fc cname) constraints) + let conapp = apply (impsBind (Elaboratable_Name fc cname) constraints) (map (const (Implicit fc True)) meths) - let fnclause = PatClause fc (IApp fc (IVar fc hintname) conapp) - (IVar fc cn) - let fndef = IDef fc hintname [fnclause] + let fnclause = PatClause fc (Elaboratable_Apply fc (Elaboratable_Name fc hintname) conapp) + (Elaboratable_Name fc cn) + let fndef = Elaboratable_Definition fc hintname [fnclause] pure (hintname, [tydecl, fndef]) where impsBind : RawImp -> List Name -> RawImp impsBind fn [] = fn impsBind fn (n :: ns) - = impsBind (IAutoApp fc fn (IBindVar fc n)) ns + = impsBind (Elaboratable_Automatic_Apply fc fn (Elaboratable_Bind_Name fc n)) ns getDefault : ImpDecl -> Maybe (FC, List FnOpt, Name, List ImpClause) -getDefault (IDef fc n cs) = Just (fc, [], n, cs) +getDefault (Elaboratable_Definition fc n cs) = Just (fc, [], n, cs) getDefault _ = Nothing mkCon : FC -> Name -> Name @@ -382,14 +382,14 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod Just d => pure (d.count, d.type) Nothing => throw (GenericMsg dfc ("No method named " ++ show n ++ " in interface " ++ show iname)) - let ity = apply (IVar vdfc iname) (map (IVar vdfc) paramNames) + let ity = apply (Elaboratable_Name vdfc iname) (map (Elaboratable_Name vdfc) paramNames) -- Substitute the method names with their top level function -- name, so they don't get implicitly bound in the name methNameMap <- traverse (\d => do let n = d.name.val cn <- inCurrentNS n - pure (n, applyParams (IVar vdfc cn) paramNames)) + pure (n, applyParams (Elaboratable_Name vdfc cn) paramNames)) tydecls let dty = bindPs params -- bind parameters $ bindIFace vdfc ity -- bind interface (?!) @@ -398,8 +398,8 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod dty_imp <- bindTypeNames dfc [] (map (val . name) tydecls ++ toList vars) dty log "elab.interface.default" 5 $ "Default method " ++ show dn ++ " : " ++ show dty_imp - let dtydecl = IClaim $ MkFCVal vdfc - $ MkIClaimData rig (collapseDefault def_vis) [] + let dtydecl = Elaboratable_Claim $ MkFCVal vdfc + $ Make_Elaboratable_Claim_Data rig (collapseDefault def_vis) [] $ Mk [EmptyFC, NoFC dn] dty_imp processDecl [] nest env dtydecl @@ -407,7 +407,7 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod cs' <- traverse (changeName dn) cs log "elab.interface.default" 5 $ "Default method body " ++ show cs' - processDecl [] nest env (IDef vdfc dn cs') + processDecl [] nest env (Elaboratable_Definition vdfc dn cs') -- Reset the original context, we don't need to keep the definition -- Actually we do for the metadata and name map! -- put Ctxt orig @@ -421,29 +421,29 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod bindPs : List (Name, (RigCount, RawImp)) -> RawImp -> RawImp bindPs [] ty = ty bindPs ((n, (rig, pty)) :: ps) ty - = IPi (getFC pty) rig Implicit (Just n) pty (bindPs ps ty) + = Elaboratable_Dependent_Function_Type (getFC pty) rig Implicit (Just n) pty (bindPs ps ty) applyParams : RawImp -> List Name -> RawImp applyParams tm [] = tm applyParams tm (n@(UN (Basic _)) :: ns) - = applyParams (INamedApp vdfc tm n (IBindVar vdfc n)) ns + = applyParams (Elaboratable_Named_Apply vdfc tm n (Elaboratable_Bind_Name vdfc n)) ns applyParams tm (_ :: ns) = applyParams tm ns changeNameTerm : Name -> RawImp -> Core RawImp - changeNameTerm dn (IVar fc n') - = do if n /= n' then pure (IVar fc n') else do + changeNameTerm dn (Elaboratable_Name fc n') + = do if n /= n' then pure (Elaboratable_Name fc n') else do log "ide-mode.highlight" 7 $ "elabDefault is trying to add Function: " ++ show n ++ " (" ++ show fc ++")" whenJust (isConcreteFC fc) $ \nfc => do log "ide-mode.highlight" 7 $ "elabDefault is adding Function: " ++ show n addSemanticDecorations [(nfc, Function, Just n)] - pure (IVar fc dn) - changeNameTerm dn (IApp fc f arg) - = IApp fc <$> changeNameTerm dn f <*> pure arg - changeNameTerm dn (IAutoApp fc f arg) - = IAutoApp fc <$> changeNameTerm dn f <*> pure arg - changeNameTerm dn (INamedApp fc f x arg) - = INamedApp fc <$> changeNameTerm dn f <*> pure x <*> pure arg + pure (Elaboratable_Name fc dn) + changeNameTerm dn (Elaboratable_Apply fc f arg) + = Elaboratable_Apply fc <$> changeNameTerm dn f <*> pure arg + changeNameTerm dn (Elaboratable_Automatic_Apply fc f arg) + = Elaboratable_Automatic_Apply fc <$> changeNameTerm dn f <*> pure arg + changeNameTerm dn (Elaboratable_Named_Apply fc f x arg) + = Elaboratable_Named_Apply fc <$> changeNameTerm dn f <*> pure x <*> pure arg changeNameTerm dn tm = pure tm changeName : Name -> ImpClause -> Core ImpClause diff --git a/Idris/REPL.idr b/Idris/REPL.idr index 84c00483b0..85316edc41 100644 --- a/Idris/REPL.idr +++ b/Idris/REPL.idr @@ -333,7 +333,7 @@ nextGenDef reject dropLams : Nat -> RawImp' nm -> RawImp' nm dropLams Z tm = tm -dropLams (S k) (ILam _ _ _ _ _ sc) = dropLams k sc +dropLams (S k) (Elaboratable_Lambda _ _ _ _ _ sc) = dropLams k sc dropLams _ tm = tm dropLamsTm : {vars : _} -> @@ -390,10 +390,10 @@ getItDecls Nothing => pure [] Just n => let it = UN $ Basic "it" in - pure [ IClaim - (MkFCVal replFC $ MkIClaimData top Private [] + pure [ Elaboratable_Claim + (MkFCVal replFC $ Make_Elaboratable_Claim_Data top Private [] $ Mk [replFC, NoFC it] (Implicit replFC False)) - , IDef replFC it [PatClause replFC (IVar replFC it) (IVar replFC n)]] + , Elaboratable_Definition replFC it [PatClause replFC (Elaboratable_Name replFC it) (Elaboratable_Name replFC n)]] ||| Produce the elaboration of a PTerm, along with its inferred type inferAndElab : @@ -409,7 +409,7 @@ inferAndElab : Core (TermWithType vars) inferAndElab emode itm env = do ttimp <- desugar AnyExpr (toList vars) itm - let ttimpWithIt = ILocal replFC !getItDecls ttimp + let ttimpWithIt = Elaboratable_Local_Definitions replFC !getItDecls ttimp inidx <- resolveName (UN $ Basic "[input]") -- a TMP HACK to prioritise list syntax for List: hide -- foreign argument lists. TODO: once the new FFI is fully @@ -732,7 +732,7 @@ prepareExp : PTerm -> Core ClosedTerm prepareExp ctm = do ttimp <- desugar AnyExpr [] (PApp replFC (PRef replFC (UN $ Basic "unsafePerformIO")) ctm) - let ttimpWithIt = ILocal replFC !getItDecls ttimp + let ttimpWithIt = Elaboratable_Local_Definitions replFC !getItDecls ttimp inidx <- resolveName (UN $ Basic "[input]") (tm, ty) <- elabTerm inidx InExpr [] (MkNested []) Env.empty ttimpWithIt Nothing diff --git a/Idris/Resugar.idr b/Idris/Resugar.idr index e26c9da3a7..0687d1d1ed 100644 --- a/Idris/Resugar.idr +++ b/Idris/Resugar.idr @@ -273,15 +273,15 @@ toPRef fc (MkKindedName nt fn nm) = case dropNS nm of mutual toPTerm : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - (prec : Nat) -> IRawImp -> Core IPTerm - toPTerm p (IVar fc nm) = do + (prec : Nat) -> Kinded_Elaboratable_Term -> Core IPTerm + toPTerm p (Elaboratable_Name fc nm) = do t <- if fullNamespace !(getPPrint) then pure $ PRef fc nm else toPRef fc nm log "resugar.var" 70 $ unwords [ "Resugaring", show @{Raw} nm.rawName, "to", show t] pure t - toPTerm p (IPi fc rig Implicit n arg ret) + toPTerm p (Elaboratable_Dependent_Function_Type fc rig Implicit n arg ret) = do imp <- showImplicits if imp then do arg' <- toPTerm tyPrec arg @@ -300,12 +300,12 @@ mutual allNs = findAllNames [] ret in (nm `elem` allNs) && not (nm `elem` (map Builtin.fst ns)) needsBind _ = False - toPTerm p (IPi fc rig pt n arg ret) + toPTerm p (Elaboratable_Dependent_Function_Type fc rig pt n arg ret) = do arg' <- toPTerm appPrec arg ret' <- toPTerm tyPrec ret pt' <- traverse (toPTerm argPrec) pt bracket p tyPrec (PPi fc rig pt' n arg' ret') - toPTerm p (ILam fc rig pt mn arg sc) + toPTerm p (Elaboratable_Lambda fc rig pt mn arg sc) = do let n = case mn of Nothing => UN Underscore Just n' => n' @@ -316,7 +316,7 @@ mutual pt' <- traverse (toPTerm argPrec) pt let var = PRef fc (MkKindedName (Just Bound) n n) bracket p startPrec (PLam fc rig pt' var arg' sc') - toPTerm p (ILet fc lhsFC rig n ty val sc) + toPTerm p (Elaboratable_Binding fc lhsFC rig n ty val sc) = do imp <- showImplicits ty' <- if imp then toPTerm startPrec ty else pure (PImplicit fc) @@ -324,13 +324,13 @@ mutual sc' <- toPTerm startPrec sc let var = PRef lhsFC (MkKindedName (Just Bound) n n) bracket p startPrec (PLet fc rig var ty' val' sc' []) - toPTerm p (ICase fc _ sc scty [PatClause _ lhs rhs]) + toPTerm p (Elaboratable_Case fc _ sc scty [PatClause _ lhs rhs]) = do sc' <- toPTerm startPrec sc lhs' <- toPTerm startPrec lhs rhs' <- toPTerm startPrec rhs bracket p startPrec (PLet fc top lhs' (PImplicit fc) sc' rhs' []) - toPTerm p (ICase fc opts sc scty alts) + toPTerm p (Elaboratable_Case fc opts sc scty alts) = do opts' <- traverse toPFnOpt opts sc' <- toPTerm startPrec sc alts' <- traverse toPClause alts @@ -345,65 +345,65 @@ mutual then PIfThenElse loc sc t f else tm mkIf tm = tm - toPTerm p (ILocal fc ds sc) + toPTerm p (Elaboratable_Local_Definitions fc ds sc) = do ds' <- traverse toPDecl ds sc' <- toPTerm startPrec sc bracket p startPrec (PLocal fc (catMaybes ds') sc') - toPTerm p (ICaseLocal fc _ _ _ sc) = toPTerm p sc - toPTerm p (IUpdate fc ds f) + toPTerm p (Elaboratable_Case_Local_Definition fc _ _ _ sc) = toPTerm p sc + toPTerm p (Elaboratable_Record_Update fc ds f) = do ds' <- traverse toPFieldUpdate ds f' <- toPTerm argPrec f bracket p startPrec (PApp fc (PUpdate fc ds') f') - toPTerm p (IApp fc fn arg) + toPTerm p (Elaboratable_Apply fc fn arg) = do arg' <- toPTerm argPrec arg app <- toPTermApp fn [(fc, Nothing, arg')] bracket p appPrec app - toPTerm p (IAutoApp fc fn arg) + toPTerm p (Elaboratable_Automatic_Apply fc fn arg) = do arg' <- toPTerm argPrec arg app <- toPTermApp fn [(fc, Just Nothing, arg')] bracket p appPrec app - toPTerm p (IWithApp fc fn arg) + toPTerm p (Elaboratable_With_Apply fc fn arg) = do arg' <- toPTerm startPrec arg fn' <- toPTerm startPrec fn bracket p appPrec (PWithApp fc fn' arg') - toPTerm p (INamedApp fc fn n arg) + toPTerm p (Elaboratable_Named_Apply fc fn n arg) = do arg' <- toPTerm startPrec arg app <- toPTermApp fn [(fc, Just (Just n), arg')] imp <- showImplicits if imp then bracket p startPrec app else mkOp app - toPTerm p (ISearch fc d) = pure (PSearch fc d) - toPTerm p (IAlternative fc _ _) = pure (PImplicit fc) - toPTerm p (IRewrite fc rule tm) + toPTerm p (Elaboratable_Search fc d) = pure (PSearch fc d) + toPTerm p (Elaboratable_Alternative fc _ _) = pure (PImplicit fc) + toPTerm p (Elaboratable_Rewrite fc rule tm) = pure (PRewrite fc !(toPTerm startPrec rule) !(toPTerm startPrec tm)) - toPTerm p (ICoerced fc tm) = toPTerm p tm - toPTerm p (IPrimVal fc c) = pure (PPrimVal fc c) - toPTerm p (IHole fc str) = pure (PHole fc False str) - toPTerm p (IType fc) = pure (PType fc) - toPTerm p (IBindVar fc nm) + toPTerm p (Elaboratable_Coerced fc tm) = toPTerm p tm + toPTerm p (Elaboratable_Primitive_Value fc c) = pure (PPrimVal fc c) + toPTerm p (Elaboratable_Hole fc str) = pure (PHole fc False str) + toPTerm p (Elaboratable_Type_Universe fc) = pure (PType fc) + toPTerm p (Elaboratable_Bind_Name fc nm) = pure (PRef fc (MkKindedName (Just Bound) nm nm)) - toPTerm p (IBindHere fc _ tm) = toPTerm p tm - toPTerm p (IAs fc nameFC _ n pat) = pure (PAs fc nameFC n !(toPTerm argPrec pat)) - toPTerm p (IMustUnify fc r pat) = pure (PDotted fc !(toPTerm argPrec pat)) - - toPTerm p (IDelayed fc r ty) = pure (PDelayed fc r !(toPTerm argPrec ty)) - toPTerm p (IDelay fc tm) = pure (PDelay fc !(toPTerm argPrec tm)) - toPTerm p (IForce fc tm) = pure (PForce fc !(toPTerm argPrec tm)) - toPTerm p (IQuote fc tm) = pure (PQuote fc !(toPTerm argPrec tm)) - toPTerm p (IQuoteName fc n) = pure (PQuoteName fc n) - toPTerm p (IQuoteDecl fc ds) + toPTerm p (Elaboratable_Bind_Here fc _ tm) = toPTerm p tm + toPTerm p (Elaboratable_As_Pattern fc nameFC _ n pat) = pure (PAs fc nameFC n !(toPTerm argPrec pat)) + toPTerm p (Elaboratable_Must_Unify fc r pat) = pure (PDotted fc !(toPTerm argPrec pat)) + + toPTerm p (Elaboratable_Delayed_Type fc r ty) = pure (PDelayed fc r !(toPTerm argPrec ty)) + toPTerm p (Elaboratable_Delay fc tm) = pure (PDelay fc !(toPTerm argPrec tm)) + toPTerm p (Elaboratable_Force fc tm) = pure (PForce fc !(toPTerm argPrec tm)) + toPTerm p (Elaboratable_Quote fc tm) = pure (PQuote fc !(toPTerm argPrec tm)) + toPTerm p (Elaboratable_Quote_Name fc n) = pure (PQuoteName fc n) + toPTerm p (Elaboratable_Quote_Declarations fc ds) = do ds' <- traverse toPDecl ds pure $ PQuoteDecl fc (catMaybes ds') - toPTerm p (IUnquote fc tm) = pure (PUnquote fc !(toPTerm argPrec tm)) - toPTerm p (IRunElab fc _ tm) = pure (PRunElab fc !(toPTerm argPrec tm)) + toPTerm p (Elaboratable_Unquote fc tm) = pure (PUnquote fc !(toPTerm argPrec tm)) + toPTerm p (Elaboratable_Run_Elaborator fc _ tm) = pure (PRunElab fc !(toPTerm argPrec tm)) - toPTerm p (IUnifyLog fc _ tm) = toPTerm p tm + toPTerm p (Elaboratable_Unification_Log fc _ tm) = toPTerm p tm toPTerm p (Implicit fc True) = pure (PImplicit fc) toPTerm p (Implicit fc False) = pure (PInfer fc) - toPTerm p (IWithUnambigNames fc ns rhs) = + toPTerm p (Elaboratable_With_Unambiguous_Names fc ns rhs) = PWithUnambigNames fc ns <$> toPTerm startPrec rhs mkApp : {auto c : Ref Ctxt Defs} -> @@ -427,15 +427,15 @@ mutual toPTermApp : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - IRawImp -> List (FC, Maybe (Maybe Name), IPTerm) -> + Kinded_Elaboratable_Term -> List (FC, Maybe (Maybe Name), IPTerm) -> Core IPTerm - toPTermApp (IApp fc f a) args + toPTermApp (Elaboratable_Apply fc f a) args = do a' <- toPTerm argPrec a toPTermApp f ((fc, Nothing, a') :: args) - toPTermApp (INamedApp fc f n a) args + toPTermApp (Elaboratable_Named_Apply fc f n a) args = do a' <- toPTerm startPrec a toPTermApp f ((fc, Just (Just n), a') :: args) - toPTermApp fn@(IVar fc n) args + toPTermApp fn@(Elaboratable_Name fc n) args = do defs <- get Ctxt case !(lookupCtxtExact (rawName n) (gamma defs)) of Nothing => do fn' <- toPTerm appPrec fn @@ -453,11 +453,11 @@ mutual toPFieldUpdate : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - IFieldUpdate' KindedName -> Core (PFieldUpdate' KindedName) - toPFieldUpdate (ISetField p v) + Elaboratable_Field_Update' KindedName -> Core (PFieldUpdate' KindedName) + toPFieldUpdate (Elaboratable_Set_Field p v) = do v' <- toPTerm startPrec v pure (PSetField p v') - toPFieldUpdate (ISetFieldApp p v) + toPFieldUpdate (Elaboratable_Apply_To_Field p v) = do v' <- toPTerm startPrec v pure (PSetFieldApp p v') @@ -494,7 +494,7 @@ mutual toPField : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - IField' KindedName -> Core (PField' KindedName) + Elaboratable_Field' KindedName -> Core (PField' KindedName) toPField field = do bind' <- traverse (toPTerm startPrec) field.val pure (Mk [field.fc , "", field.rig, [field.name]] bind') @@ -510,14 +510,14 @@ mutual toPDecl : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> ImpDecl' KindedName -> Core (Maybe (PDecl' KindedName)) - toPDecl (IClaim (MkWithData fc $ MkIClaimData rig vis opts ty)) + toPDecl (Elaboratable_Claim (MkWithData fc $ Make_Elaboratable_Claim_Data rig vis opts ty)) = do opts' <- traverse toPFnOpt opts pure (Just (MkWithData fc $ PClaim (MkPClaim rig vis opts' !(toPTypeDecl ty)))) - toPDecl (IData fc vis mbtot d) + toPDecl (Elaboratable_Data_Declaration fc vis mbtot d) = pure (Just (MkFCVal fc $ PData "" vis mbtot !(toPData d))) - toPDecl (IDef fc n cs) + toPDecl (Elaboratable_Definition fc n cs) = pure (Just (MkFCVal fc $ PDef !(traverse toPClause cs))) - toPDecl (IParameters fc ps ds) + toPDecl (Elaboratable_Parameter_Block fc ps ds) = do ds' <- traverse toPDecl ds args <- traverseList1 (\binder => @@ -525,7 +525,7 @@ mutual type' <- toPTerm startPrec binder.val.boundType pure (MkFullBinder info' binder.rig binder.name type')) ps pure (Just (MkFCVal fc (PParameters (Right args) (catMaybes ds')))) - toPDecl (IRecord fc _ vis mbtot (MkWithData _ $ MkImpRecord header body)) + toPDecl (Elaboratable_Record_Declaration fc _ vis mbtot (MkWithData _ $ MkImpRecord header body)) = do ps' <- traverse (traverse (traverse (toPTerm startPrec))) header.val fs' <- traverse toPField body.val pure (Just (MkFCVal fc $ PRecord "" vis mbtot @@ -535,21 +535,21 @@ mutual toBinder binder = MkFullBinder binder.val.info binder.rig binder.name binder.val.boundType - toPDecl (IFail fc msg ds) + toPDecl (Elaboratable_Expected_Failure fc msg ds) = do ds' <- traverse toPDecl ds pure (Just (MkFCVal fc $ PFail msg (catMaybes ds'))) - toPDecl (INamespace fc ns ds) + toPDecl (Elaboratable_Namespace_Block fc ns ds) = do ds' <- traverse toPDecl ds pure (Just (MkFCVal fc $ PNamespace ns (catMaybes ds'))) - toPDecl (ITransform fc n lhs rhs) + toPDecl (Elaboratable_Transformation fc n lhs rhs) = pure (Just (MkFCVal fc $ PTransform (show n) !(toPTerm startPrec lhs) !(toPTerm startPrec rhs))) - toPDecl (IRunElabDecl fc tm) + toPDecl (Elaboratable_Run_Elaborator_Declaration fc tm) = pure (Just (MkFCVal fc $ PRunElabDecl !(toPTerm startPrec tm))) - toPDecl (IPragma {}) = pure Nothing - toPDecl (ILog _) = pure Nothing - toPDecl (IBuiltin fc type name) = pure $ Just $ MkFCVal fc $ PBuiltin type name + toPDecl (Elaboratable_Pragma {}) = pure Nothing + toPDecl (Elaboratable_Logging _) = pure Nothing + toPDecl (Elaboratable_Builtin_Declaration fc type name) = pure $ Just $ MkFCVal fc $ PBuiltin type name export cleanPTerm : {auto c : Ref Ctxt Defs} -> @@ -596,7 +596,7 @@ cleanPTerm ptm toCleanPTerm : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - (prec : Nat) -> IRawImp -> Core IPTerm + (prec : Nat) -> Kinded_Elaboratable_Term -> Core IPTerm toCleanPTerm prec tti = do ptm <- toPTerm prec tti cleanPTerm ptm @@ -622,5 +622,5 @@ resugarNoPatvars env tm export pterm : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - IRawImp -> Core IPTerm + Kinded_Elaboratable_Term -> Core IPTerm pterm raw = toCleanPTerm startPrec raw diff --git a/Idris/Syntax.idr b/Idris/Syntax.idr index 49b75928d4..50777fa671 100644 --- a/Idris/Syntax.idr +++ b/Idris/Syntax.idr @@ -1098,7 +1098,7 @@ initSyntax initDocStrings [] [] - (IVar EmptyFC (UN $ Basic "main")) + (Elaboratable_Name EmptyFC (UN $ Basic "main")) [] where diff --git a/TTIMP_READABLE_NAMES.md b/TTIMP_READABLE_NAMES.md new file mode 100644 index 0000000000..e656920162 --- /dev/null +++ b/TTIMP_READABLE_NAMES.md @@ -0,0 +1,88 @@ +# Readable TTImp names + +This branch spells out the constructor vocabulary of Idris's compiler-internal raw, elaboratable term layer. +`Elaboratable_` replaces the unexplained one-letter constructor prefix and keeps these names distinct from the checked core term constructors. +The compiler source itself describes this layer as the raw form which is elaborated into checked core terms. + +## Main reading vocabulary + +| Upstream name | Name on this branch | Meaning | +|---|---|---| +| `IVar` | `Elaboratable_Name` | a referenced name | +| `IApp` | `Elaboratable_Apply` | apply one term to another | +| `ILet` | `Elaboratable_Binding` | a local binding | +| `IPi` | `Elaboratable_Dependent_Function_Type` | a function type whose result may depend on its input | +| `ILam` | `Elaboratable_Lambda` | a lambda expression | +| `ICase` | `Elaboratable_Case` | a case expression | + +## Complete compiler-internal rename + +| Upstream name | Name on this branch | Source occurrences changed | +|---|---|---:| +| `IAlternative` | `Elaboratable_Alternative` | 46 | +| `IApp` | `Elaboratable_Apply` | 108 | +| `IArg` | `Kinded_Elaboratable_Argument` | 3 | +| `IAs` | `Elaboratable_As_Pattern` | 59 | +| `IAutoApp` | `Elaboratable_Automatic_Apply` | 82 | +| `IBindHere` | `Elaboratable_Bind_Here` | 35 | +| `IBindVar` | `Elaboratable_Bind_Name` | 54 | +| `IBuiltin` | `Elaboratable_Builtin_Declaration` | 15 | +| `ICase` | `Elaboratable_Case` | 34 | +| `ICaseLocal` | `Elaboratable_Case_Local_Definition` | 15 | +| `IClaim` | `Elaboratable_Claim` | 39 | +| `IClaimData` | `Elaboratable_Claim_Data` | 6 | +| `ICoerced` | `Elaboratable_Coerced` | 21 | +| `IData` | `Elaboratable_Data_Declaration` | 35 | +| `IDef` | `Elaboratable_Definition` | 46 | +| `IDelay` | `Elaboratable_Delay` | 34 | +| `IDelayed` | `Elaboratable_Delayed_Type` | 35 | +| `IFail` | `Elaboratable_Expected_Failure` | 21 | +| `IField` | `Elaboratable_Field` | 15 | +| `IField'` | `Elaboratable_Field'` | 6 | +| `IFieldUpdate` | `Elaboratable_Field_Update` | 16 | +| `IFieldUpdate'` | `Elaboratable_Field_Update'` | 15 | +| `IForce` | `Elaboratable_Force` | 34 | +| `IHole` | `Elaboratable_Hole` | 24 | +| `IImpClause` | `Kinded_Elaboratable_Clause` | 3 | +| `ILam` | `Elaboratable_Lambda` | 61 | +| `ILet` | `Elaboratable_Binding` | 28 | +| `ILocal` | `Elaboratable_Local_Definitions` | 30 | +| `ILog` | `Elaboratable_Logging` | 17 | +| `IMustUnify` | `Elaboratable_Must_Unify` | 39 | +| `INamedApp` | `Elaboratable_Named_Apply` | 101 | +| `INamespace` | `Elaboratable_Namespace_Block` | 29 | +| `IParameters` | `Elaboratable_Parameter_Block` | 22 | +| `IPi` | `Elaboratable_Dependent_Function_Type` | 75 | +| `IPragma` | `Elaboratable_Pragma` | 45 | +| `IPrimVal` | `Elaboratable_Primitive_Value` | 45 | +| `IQuote` | `Elaboratable_Quote` | 25 | +| `IQuoteDecl` | `Elaboratable_Quote_Declarations` | 18 | +| `IQuoteName` | `Elaboratable_Quote_Name` | 17 | +| `IRawImp` | `Kinded_Elaboratable_Term` | 25 | +| `IRecord` | `Elaboratable_Record_Declaration` | 23 | +| `IRewrite` | `Elaboratable_Rewrite` | 22 | +| `IRunElab` | `Elaboratable_Run_Elaborator` | 17 | +| `IRunElabDecl` | `Elaboratable_Run_Elaborator_Declaration` | 14 | +| `ISearch` | `Elaboratable_Search` | 22 | +| `ISetField` | `Elaboratable_Set_Field` | 22 | +| `ISetFieldApp` | `Elaboratable_Apply_To_Field` | 22 | +| `ITransform` | `Elaboratable_Transformation` | 18 | +| `IType` | `Elaboratable_Type_Universe` | 25 | +| `IUnifyLog` | `Elaboratable_Unification_Log` | 13 | +| `IUnquote` | `Elaboratable_Unquote` | 23 | +| `IUpdate` | `Elaboratable_Record_Update` | 35 | +| `IVar` | `Elaboratable_Name` | 206 | +| `IWithApp` | `Elaboratable_With_Apply` | 52 | +| `IWithUnambigNames` | `Elaboratable_With_Unambiguous_Names` | 16 | +| `MkIClaimData` | `Make_Elaboratable_Claim_Data` | 29 | +| `findIBinds` | `find_names_to_bind` | 49 | +| `isIBindVar` | `is_elaboratable_bound_name` | 4 | +| `isIPrimVal` | `is_primitive_value` | 4 | +| `isIVar` | `is_elaboratable_name` | 4 | +| `unIArg` | `elaboratable_argument_term` | 4 | + +## Reflection compatibility boundary + +The public constructors in `_/libs/base/Language/Reflection/TTImp.idr` retain their upstream names. +Those names are part of the elaborator-reflection interface and are embedded in the checked-in bootstrap compiler. +`TTImp/Reflect.idr` uses readable constructors internally while translating to and from the established serialized names. diff --git a/TTImp/BindImplicits.idr b/TTImp/BindImplicits.idr index 014a0ccd16..9a69a129ff 100644 --- a/TTImp/BindImplicits.idr +++ b/TTImp/BindImplicits.idr @@ -16,105 +16,105 @@ export renameIBinds : (renames : List String) -> (used : List String) -> RawImp -> State (List (String, String)) RawImp -renameIBinds rs us (IPi fc c p (Just un@(UN (Basic n))) ty sc) +renameIBinds rs us (Elaboratable_Dependent_Function_Type fc c p (Just un@(UN (Basic n))) ty sc) = if n `elem` rs then let n' = genUniqueStr (rs ++ us) n un' = UN (Basic n') sc' = substNames (map (UN . Basic) (filter (/= n) us)) - [(un, IVar fc un')] sc in + [(un, Elaboratable_Name fc un')] sc in do scr <- renameIBinds rs (n' :: us) sc' ty' <- renameIBinds rs us ty upds <- get put ((n, n') :: upds) - pure $ IPi fc c p (Just un') ty' scr + pure $ Elaboratable_Dependent_Function_Type fc c p (Just un') ty' scr else do scr <- renameIBinds rs us sc ty' <- renameIBinds rs us ty - pure $ IPi fc c p (Just un) ty' scr -renameIBinds rs us (IPi fc c p n ty sc) - = pure $ IPi fc c p n !(renameIBinds rs us ty) !(renameIBinds rs us sc) -renameIBinds rs us (ILam fc c p n ty sc) - = pure $ ILam fc c p n !(renameIBinds rs us ty) !(renameIBinds rs us sc) -renameIBinds rs us (IApp fc fn arg) - = pure $ IApp fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) -renameIBinds rs us (IAutoApp fc fn arg) - = pure $ IAutoApp fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) -renameIBinds rs us (INamedApp fc fn n arg) - = pure $ INamedApp fc !(renameIBinds rs us fn) n !(renameIBinds rs us arg) -renameIBinds rs us (IWithApp fc fn arg) - = pure $ IWithApp fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) -renameIBinds rs us (IAs fc nameFC s n pat) - = pure $ IAs fc nameFC s n !(renameIBinds rs us pat) -renameIBinds rs us (IMustUnify fc r pat) - = pure $ IMustUnify fc r !(renameIBinds rs us pat) -renameIBinds rs us (IDelayed fc r t) - = pure $ IDelayed fc r !(renameIBinds rs us t) -renameIBinds rs us (IDelay fc t) - = pure $ IDelay fc !(renameIBinds rs us t) -renameIBinds rs us (IForce fc t) - = pure $ IForce fc !(renameIBinds rs us t) -renameIBinds rs us (IUpdate fc updates tm) - = pure $ IUpdate fc !(traverse f updates) !(renameIBinds rs us tm) + pure $ Elaboratable_Dependent_Function_Type fc c p (Just un) ty' scr +renameIBinds rs us (Elaboratable_Dependent_Function_Type fc c p n ty sc) + = pure $ Elaboratable_Dependent_Function_Type fc c p n !(renameIBinds rs us ty) !(renameIBinds rs us sc) +renameIBinds rs us (Elaboratable_Lambda fc c p n ty sc) + = pure $ Elaboratable_Lambda fc c p n !(renameIBinds rs us ty) !(renameIBinds rs us sc) +renameIBinds rs us (Elaboratable_Apply fc fn arg) + = pure $ Elaboratable_Apply fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) +renameIBinds rs us (Elaboratable_Automatic_Apply fc fn arg) + = pure $ Elaboratable_Automatic_Apply fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) +renameIBinds rs us (Elaboratable_Named_Apply fc fn n arg) + = pure $ Elaboratable_Named_Apply fc !(renameIBinds rs us fn) n !(renameIBinds rs us arg) +renameIBinds rs us (Elaboratable_With_Apply fc fn arg) + = pure $ Elaboratable_With_Apply fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) +renameIBinds rs us (Elaboratable_As_Pattern fc nameFC s n pat) + = pure $ Elaboratable_As_Pattern fc nameFC s n !(renameIBinds rs us pat) +renameIBinds rs us (Elaboratable_Must_Unify fc r pat) + = pure $ Elaboratable_Must_Unify fc r !(renameIBinds rs us pat) +renameIBinds rs us (Elaboratable_Delayed_Type fc r t) + = pure $ Elaboratable_Delayed_Type fc r !(renameIBinds rs us t) +renameIBinds rs us (Elaboratable_Delay fc t) + = pure $ Elaboratable_Delay fc !(renameIBinds rs us t) +renameIBinds rs us (Elaboratable_Force fc t) + = pure $ Elaboratable_Force fc !(renameIBinds rs us t) +renameIBinds rs us (Elaboratable_Record_Update fc updates tm) + = pure $ Elaboratable_Record_Update fc !(traverse f updates) !(renameIBinds rs us tm) where - f : IFieldUpdate -> State (List (String, String)) IFieldUpdate - f (ISetField path x) = ISetField path <$> renameIBinds rs us x - f (ISetFieldApp path x) = ISetFieldApp path <$> renameIBinds rs us x -renameIBinds rs us (IAlternative fc u alts) - = pure $ IAlternative fc !(renameAlt u) + f : Elaboratable_Field_Update -> State (List (String, String)) Elaboratable_Field_Update + f (Elaboratable_Set_Field path x) = Elaboratable_Set_Field path <$> renameIBinds rs us x + f (Elaboratable_Apply_To_Field path x) = Elaboratable_Apply_To_Field path <$> renameIBinds rs us x +renameIBinds rs us (Elaboratable_Alternative fc u alts) + = pure $ Elaboratable_Alternative fc !(renameAlt u) !(traverse (renameIBinds rs us) alts) where renameAlt : AltType -> State (List (String, String)) AltType renameAlt (UniqueDefault t) = pure $ UniqueDefault !(renameIBinds rs us t) renameAlt u = pure u -renameIBinds rs us (IBindVar fc nm@(UN (Basic n))) +renameIBinds rs us (Elaboratable_Bind_Name fc nm@(UN (Basic n))) = if n `elem` rs then do let n' = genUniqueStr (rs ++ us) n upds <- get put ((n, n') :: upds) - pure $ IBindVar fc (UN (Basic n')) - else pure $ IBindVar fc nm + pure $ Elaboratable_Bind_Name fc (UN (Basic n')) + else pure $ Elaboratable_Bind_Name fc nm renameIBinds rs us tm = pure $ tm export doBind : List (Name, Name) -> RawImp -> RawImp doBind [] tm = tm -doBind ns (IVar fc nm) - = maybe (IVar fc nm) (IBindVar fc) (lookup nm ns) -doBind ns (IPi fc rig p mn aty retty) +doBind ns (Elaboratable_Name fc nm) + = maybe (Elaboratable_Name fc nm) (Elaboratable_Bind_Name fc) (lookup nm ns) +doBind ns (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) = let ns' = case mn of Just nm => filter (\x => fst x /= nm) ns _ => ns in - IPi fc rig p mn (doBind ns' aty) (doBind ns' retty) -doBind ns (ILam fc rig p mn aty sc) + Elaboratable_Dependent_Function_Type fc rig p mn (doBind ns' aty) (doBind ns' retty) +doBind ns (Elaboratable_Lambda fc rig p mn aty sc) = let ns' = case mn of Just nm => filter (\x => fst x /= nm) ns _ => ns in - ILam fc rig p mn (doBind ns' aty) (doBind ns' sc) -doBind ns (IApp fc fn av) - = IApp fc (doBind ns fn) (doBind ns av) -doBind ns (IAutoApp fc fn av) - = IAutoApp fc (doBind ns fn) (doBind ns av) -doBind ns (INamedApp fc fn n av) - = INamedApp fc (doBind ns fn) n (doBind ns av) -doBind ns (IWithApp fc fn av) - = IWithApp fc (doBind ns fn) (doBind ns av) -doBind ns (IAs fc nameFC s n pat) - = IAs fc nameFC s n (doBind ns pat) -doBind ns (IMustUnify fc r pat) - = IMustUnify fc r (doBind ns pat) -doBind ns (IDelayed fc r ty) - = IDelayed fc r (doBind ns ty) -doBind ns (IDelay fc tm) - = IDelay fc (doBind ns tm) -doBind ns (IForce fc tm) - = IForce fc (doBind ns tm) -doBind ns (IQuote fc tm) - = IQuote fc (doBind ns tm) -doBind ns (IUnquote fc tm) - = IUnquote fc (doBind ns tm) -doBind ns (IAlternative fc u alts) - = IAlternative fc (mapAltType (doBind ns) u) (map (doBind ns) alts) -doBind ns (IUpdate fc updates tm) - = IUpdate fc (map (mapFieldUpdateTerm $ doBind ns) updates) (doBind ns tm) + Elaboratable_Lambda fc rig p mn (doBind ns' aty) (doBind ns' sc) +doBind ns (Elaboratable_Apply fc fn av) + = Elaboratable_Apply fc (doBind ns fn) (doBind ns av) +doBind ns (Elaboratable_Automatic_Apply fc fn av) + = Elaboratable_Automatic_Apply fc (doBind ns fn) (doBind ns av) +doBind ns (Elaboratable_Named_Apply fc fn n av) + = Elaboratable_Named_Apply fc (doBind ns fn) n (doBind ns av) +doBind ns (Elaboratable_With_Apply fc fn av) + = Elaboratable_With_Apply fc (doBind ns fn) (doBind ns av) +doBind ns (Elaboratable_As_Pattern fc nameFC s n pat) + = Elaboratable_As_Pattern fc nameFC s n (doBind ns pat) +doBind ns (Elaboratable_Must_Unify fc r pat) + = Elaboratable_Must_Unify fc r (doBind ns pat) +doBind ns (Elaboratable_Delayed_Type fc r ty) + = Elaboratable_Delayed_Type fc r (doBind ns ty) +doBind ns (Elaboratable_Delay fc tm) + = Elaboratable_Delay fc (doBind ns tm) +doBind ns (Elaboratable_Force fc tm) + = Elaboratable_Force fc (doBind ns tm) +doBind ns (Elaboratable_Quote fc tm) + = Elaboratable_Quote fc (doBind ns tm) +doBind ns (Elaboratable_Unquote fc tm) + = Elaboratable_Unquote fc (doBind ns tm) +doBind ns (Elaboratable_Alternative fc u alts) + = Elaboratable_Alternative fc (mapAltType (doBind ns) u) (map (doBind ns) alts) +doBind ns (Elaboratable_Record_Update fc updates tm) + = Elaboratable_Record_Update fc (map (mapFieldUpdateTerm $ doBind ns) updates) (doBind ns tm) doBind ns tm = tm export @@ -152,7 +152,7 @@ getUsings ns u = concatMap (flip getUsing u) ns bindUsings : List (RigCount, PiInfo RawImp, Maybe Name, RawImp) -> RawImp -> RawImp bindUsings [] tm = tm bindUsings ((rig, p, mn, ty) :: us) tm - = IPi (getFC ty) rig p mn ty (bindUsings us tm) + = Elaboratable_Dependent_Function_Type (getFC ty) rig p mn ty (bindUsings us tm) addUsing : List (Maybe Name, RawImp) -> RawImp -> RawImp @@ -195,5 +195,5 @@ piBindNames loc env tm piBind : List Name -> RawImp -> RawImp piBind [] ty = ty piBind (n :: ns) ty - = IPi loc erased Implicit (Just n) (Implicit loc False) + = Elaboratable_Dependent_Function_Type loc erased Implicit (Just n) (Implicit loc False) $ piBind ns ty diff --git a/TTImp/Elab.idr b/TTImp/Elab.idr index 439f468444..2a9796dde6 100644 --- a/TTImp/Elab.idr +++ b/TTImp/Elab.idr @@ -260,13 +260,13 @@ checkTermSub defining mode opts nest env env' sub tm ty Core RawImp bindImps' loc env [] ty = pure ty bindImps' loc env ((n, ty) :: ntys) sc - = pure $ IPi loc erased Implicit (Just n) + = pure $ Elaboratable_Dependent_Function_Type loc erased Implicit (Just n) (Implicit loc True) !(bindImps' loc env ntys sc) bindImps : FC -> Env Term vs -> List (Name, Term vs) -> RawImp -> Core RawImp - bindImps loc env ns (IBindHere fc m ty) - = pure $ IBindHere fc m !(bindImps' loc env ns ty) + bindImps loc env ns (Elaboratable_Bind_Here fc m ty) + = pure $ Elaboratable_Bind_Here fc m !(bindImps' loc env ns ty) bindImps loc env ns ty = bindImps' loc env ns ty export diff --git a/TTImp/Elab/Ambiguity.idr b/TTImp/Elab/Ambiguity.idr index aa553395f7..4f496ff1db 100644 --- a/TTImp/Elab/Ambiguity.idr +++ b/TTImp/Elab/Ambiguity.idr @@ -27,12 +27,12 @@ expandAmbigName : {vars : _} -> ElabMode -> NestedNames vars -> Env Term vars -> RawImp -> List (FC, Maybe (Maybe Name), RawImp) -> RawImp -> Maybe (Glued vars) -> Core RawImp -expandAmbigName (InLHS _) nest env orig args (IBindVar fc n) exp +expandAmbigName (InLHS _) nest env orig args (Elaboratable_Bind_Name fc n) exp = do est <- get EST if n `elem` lhsPatVars est - then pure $ IMustUnify fc NonLinearVar orig + then pure $ Elaboratable_Must_Unify fc NonLinearVar orig else pure $ orig -expandAmbigName mode nest env orig args (IVar fc x) exp +expandAmbigName mode nest env orig args (Elaboratable_Name fc x) exp = case lookup x (names nest) of Just _ => do log "elab.ambiguous" 20 $ "Nested " ++ show x pure orig @@ -43,7 +43,7 @@ expandAmbigName mode nest env orig args (IVar fc x) exp if isNil args || notLHS mode then do log "elab.ambiguous" 20 $ "Defined in env " ++ show x pure $ orig - else pure $ IMustUnify fc VarApplied orig + else pure $ Elaboratable_Must_Unify fc VarApplied orig Nothing => do est <- get EST primNs <- getPrimNames @@ -65,7 +65,7 @@ expandAmbigName mode nest env orig args (IVar fc x) exp nalts => do log "elab.ambiguous" 10 $ "Ambiguous: " ++ joinBy ", " (map (show . fst) nalts) - pure $ IAlternative fc + pure $ Elaboratable_Alternative fc (uniqType x args primNs) (map (mkAlt primApp est) nalts) where @@ -86,21 +86,21 @@ expandAmbigName mode nest env orig args (IVar fc x) exp -- the primitive directly -- The order of the arguments have a big effect on case-tree size uniqType : Name -> List (FC, Maybe (Maybe Name), RawImp) -> PrimNames -> AltType - uniqType n [(_, _, IPrimVal fc (BI x))] (MkPrimNs (Just fi) _ _ _ _ _ _) - = UniqueDefault (IPrimVal fc (BI x)) - uniqType n [(_, _, IPrimVal fc (Str x))] (MkPrimNs _ (Just si) _ _ _ _ _) - = UniqueDefault (IPrimVal fc (Str x)) - uniqType n [(_, _, IPrimVal fc (Ch x))] (MkPrimNs _ _ (Just ci) _ _ _ _) - = UniqueDefault (IPrimVal fc (Ch x)) - uniqType n [(_, _, IPrimVal fc (Db x))] (MkPrimNs _ _ _ (Just di) _ _ _) - = UniqueDefault (IPrimVal fc (Db x)) - uniqType n [(_, _, IQuote fc tm)] (MkPrimNs _ _ _ _ (Just dt) _ _) - = UniqueDefault (IQuote fc tm) + uniqType n [(_, _, Elaboratable_Primitive_Value fc (BI x))] (MkPrimNs (Just fi) _ _ _ _ _ _) + = UniqueDefault (Elaboratable_Primitive_Value fc (BI x)) + uniqType n [(_, _, Elaboratable_Primitive_Value fc (Str x))] (MkPrimNs _ (Just si) _ _ _ _ _) + = UniqueDefault (Elaboratable_Primitive_Value fc (Str x)) + uniqType n [(_, _, Elaboratable_Primitive_Value fc (Ch x))] (MkPrimNs _ _ (Just ci) _ _ _ _) + = UniqueDefault (Elaboratable_Primitive_Value fc (Ch x)) + uniqType n [(_, _, Elaboratable_Primitive_Value fc (Db x))] (MkPrimNs _ _ _ (Just di) _ _ _) + = UniqueDefault (Elaboratable_Primitive_Value fc (Db x)) + uniqType n [(_, _, Elaboratable_Quote fc tm)] (MkPrimNs _ _ _ _ (Just dt) _ _) + = UniqueDefault (Elaboratable_Quote fc tm) {- - uniqType n [(_, _, IQuoteName fc tm)] (MkPrimNs _ _ _ _ _ (Just dn) _) - = UniqueDefault (IQuoteName fc tm) - uniqType n [(_, _, IQuoteDecl fc tm)] (MkPrimNs _ _ _ _ _ _ (Just ddl)) - = UniqueDefault (IQuoteDecl fc tm) + uniqType n [(_, _, Elaboratable_Quote_Name fc tm)] (MkPrimNs _ _ _ _ _ (Just dn) _) + = UniqueDefault (Elaboratable_Quote_Name fc tm) + uniqType n [(_, _, Elaboratable_Quote_Declarations fc tm)] (MkPrimNs _ _ _ _ _ _ (Just ddl)) + = UniqueDefault (Elaboratable_Quote_Declarations fc tm) -} uniqType _ _ _ = Unique @@ -108,11 +108,11 @@ expandAmbigName mode nest env orig args (IVar fc x) exp RawImp buildAlt f [] = f buildAlt f ((fc', Nothing, a) :: as) - = buildAlt (IApp fc' f a) as + = buildAlt (Elaboratable_Apply fc' f a) as buildAlt f ((fc', Just Nothing, a) :: as) - = buildAlt (IAutoApp fc' f a) as + = buildAlt (Elaboratable_Automatic_Apply fc' f a) as buildAlt f ((fc', Just (Just i), a) :: as) - = buildAlt (INamedApp fc' f i a) as + = buildAlt (Elaboratable_Named_Apply fc' f i a) as -- If it's not a constructor application, dot it wrapDot : Bool -> EState vars -> @@ -124,11 +124,11 @@ expandAmbigName mode nest env orig args (IVar fc x) exp wrapDot prim est (InLHS _) n' [arg] _ tm = if n' == Resolved (defining est) || prim then tm - else IMustUnify fc NotConstructor tm + else Elaboratable_Must_Unify fc NotConstructor tm wrapDot prim est (InLHS _) n' _ _ tm = if n' == Resolved (defining est) then tm - else IMustUnify fc NotConstructor tm + else Elaboratable_Must_Unify fc NotConstructor tm wrapDot _ _ _ _ _ _ tm = tm notLHS : ElabMode -> Bool @@ -140,9 +140,9 @@ expandAmbigName mode nest env orig args (IVar fc x) exp = if (Context.Macro `elem` flags def) && notLHS mode then alternativeFirstSuccess $ reverse $ allSplits args <&> \(macroArgs, extArgs) => - (IRunElab fc False $ ICoerced fc $ IVar fc n `buildAlt` macroArgs) `buildAlt` extArgs + (Elaboratable_Run_Elaborator fc False $ Elaboratable_Coerced fc $ Elaboratable_Name fc n `buildAlt` macroArgs) `buildAlt` extArgs else wrapDot prim est mode n (map (snd . snd) args) - (definition def) (buildAlt (IVar fc n) args) + (definition def) (buildAlt (Elaboratable_Name fc n) args) where -- All splits of the original list starting from the (empty, full) finishing with (full, empty) allSplits : (l : List a) -> Vect (S $ length l) (List a, List a) @@ -151,19 +151,19 @@ expandAmbigName mode nest env orig args (IVar fc x) exp alternativeFirstSuccess : forall n. Vect (S n) RawImp -> RawImp alternativeFirstSuccess [x] = x - alternativeFirstSuccess xs = IAlternative fc FirstSuccess $ toList xs + alternativeFirstSuccess xs = Elaboratable_Alternative fc FirstSuccess $ toList xs mkAlt : Bool -> EState vars -> (Name, Int, GlobalDef) -> RawImp mkAlt prim est (fullname, i, gdef) = mkTerm prim est (Resolved i) gdef -expandAmbigName mode nest env orig args (IApp fc f a) exp +expandAmbigName mode nest env orig args (Elaboratable_Apply fc f a) exp = expandAmbigName mode nest env orig ((fc, Nothing, a) :: args) f exp -expandAmbigName mode nest env orig args (INamedApp fc f n a) exp +expandAmbigName mode nest env orig args (Elaboratable_Named_Apply fc f n a) exp = expandAmbigName mode nest env orig ((fc, Just (Just n), a) :: args) f exp -expandAmbigName mode nest env orig args (IAutoApp fc f a) exp +expandAmbigName mode nest env orig args (Elaboratable_Automatic_Apply fc f a) exp = expandAmbigName mode nest env orig ((fc, Just Nothing, a) :: args) f exp expandAmbigName elabmode nest env orig args tm exp @@ -248,8 +248,8 @@ couldBeName defs target n couldBeFn : {auto c : Ref Ctxt Defs} -> {vars : _} -> Defs -> NF vars -> RawImp -> Core TypeMatch -couldBeFn defs ty (IVar _ n) = couldBeName defs ty n -couldBeFn defs ty (IAlternative {}) = pure Concrete +couldBeFn defs ty (Elaboratable_Name _ n) = couldBeName defs ty n +couldBeFn defs ty (Elaboratable_Alternative {}) = pure Concrete couldBeFn defs ty _ = pure Poly -- Returns Nothing if there's no possibility the expression's type matches @@ -282,7 +282,7 @@ notOverloadable defs (True, fn) = pure True notOverloadable defs (concrete, fn) = notOverloadableFn (getFn fn) where notOverloadableFn : RawImp -> Core Bool - notOverloadableFn (IVar _ n) + notOverloadableFn (Elaboratable_Name _ n) = do Just gdef <- lookupCtxtExact n (gamma defs) | Nothing => pure True pure False -- If the name exists, and doesn't have a concrete type @@ -332,10 +332,10 @@ checkAmbigDepth fc info throw (AmbiguityTooDeep fc (Resolved (defining est)) ambs) getName : RawImp -> Maybe Name -getName (IVar _ n) = Just n -getName (IApp _ f _) = getName f -getName (INamedApp _ f _ _) = getName f -getName (IAutoApp _ f _) = getName f +getName (Elaboratable_Name _ n) = Just n +getName (Elaboratable_Apply _ f _) = getName f +getName (Elaboratable_Named_Apply _ f _ _) = getName f +getName (Elaboratable_Automatic_Apply _ f _) = getName f getName _ = Nothing export diff --git a/TTImp/Elab/App.idr b/TTImp/Elab/App.idr index af74ab8e44..815f92e678 100644 --- a/TTImp/Elab/App.idr +++ b/TTImp/Elab/App.idr @@ -298,21 +298,21 @@ mutual (knownRet : Bool) -> RawImp -> Core Bool needsDelayExpr False _ = pure False - needsDelayExpr True (IVar fc n) + needsDelayExpr True (Elaboratable_Name fc n) = do defs <- get Ctxt pure $ case !(lookupCtxtName n (gamma defs)) of (_ :: _ :: _) => True _ => False - needsDelayExpr True (IApp _ f _) = needsDelayExpr True f - needsDelayExpr True (IAutoApp _ f _) = needsDelayExpr True f - needsDelayExpr True (INamedApp _ f _ _) = needsDelayExpr True f - needsDelayExpr True (ILam {}) = pure True - needsDelayExpr True (ICase {}) = pure True - needsDelayExpr True (ILocal {}) = pure True - needsDelayExpr True (IUpdate {}) = pure True - needsDelayExpr True (IAlternative {}) = pure True - needsDelayExpr True (ISearch {}) = pure True - needsDelayExpr True (IRewrite {}) = pure True + needsDelayExpr True (Elaboratable_Apply _ f _) = needsDelayExpr True f + needsDelayExpr True (Elaboratable_Automatic_Apply _ f _) = needsDelayExpr True f + needsDelayExpr True (Elaboratable_Named_Apply _ f _ _) = needsDelayExpr True f + needsDelayExpr True (Elaboratable_Lambda {}) = pure True + needsDelayExpr True (Elaboratable_Case {}) = pure True + needsDelayExpr True (Elaboratable_Local_Definitions {}) = pure True + needsDelayExpr True (Elaboratable_Record_Update {}) = pure True + needsDelayExpr True (Elaboratable_Alternative {}) = pure True + needsDelayExpr True (Elaboratable_Search {}) = pure True + needsDelayExpr True (Elaboratable_Rewrite {}) = pure True needsDelayExpr True _ = pure False -- On the LHS, for any concrete thing, we need to make sure we know @@ -320,16 +320,16 @@ mutual -- out to be polymorphic needsDelayLHS : {auto c : Ref Ctxt Defs} -> RawImp -> Core Bool - needsDelayLHS (IVar fc n) = pure True - needsDelayLHS (IApp _ f _) = needsDelayLHS f - needsDelayLHS (IAutoApp _ f _) = needsDelayLHS f - needsDelayLHS (INamedApp _ f _ _) = needsDelayLHS f - needsDelayLHS (IAlternative {}) = pure True - needsDelayLHS (IAs _ _ _ _ t) = needsDelayLHS t - needsDelayLHS (ISearch {}) = pure True - needsDelayLHS (IPrimVal {}) = pure True - needsDelayLHS (IType _) = pure True - needsDelayLHS (IWithUnambigNames _ _ t) = needsDelayLHS t + needsDelayLHS (Elaboratable_Name fc n) = pure True + needsDelayLHS (Elaboratable_Apply _ f _) = needsDelayLHS f + needsDelayLHS (Elaboratable_Automatic_Apply _ f _) = needsDelayLHS f + needsDelayLHS (Elaboratable_Named_Apply _ f _ _) = needsDelayLHS f + needsDelayLHS (Elaboratable_Alternative {}) = pure True + needsDelayLHS (Elaboratable_As_Pattern _ _ _ _ t) = needsDelayLHS t + needsDelayLHS (Elaboratable_Search {}) = pure True + needsDelayLHS (Elaboratable_Primitive_Value {}) = pure True + needsDelayLHS (Elaboratable_Type_Universe _) = pure True + needsDelayLHS (Elaboratable_With_Unambiguous_Names _ _ t) = needsDelayLHS t needsDelayLHS _ = pure False needsDelay : {auto c : Ref Ctxt Defs} -> @@ -399,13 +399,13 @@ mutual dotTerm : RawImp -> RawImp dotTerm tm = case tm of - IMustUnify {} => tm - IBindVar {} => tm + Elaboratable_Must_Unify {} => tm + Elaboratable_Bind_Name {} => tm Implicit {} => tm - IAs _ _ _ _ (IBindVar {}) => tm - IAs _ _ _ _ (Implicit {}) => tm - IAs fc nameFC p t arg => IAs fc nameFC p t (IMustUnify fc ErasedArg tm) - _ => IMustUnify (getFC tm) ErasedArg tm + Elaboratable_As_Pattern _ _ _ _ (Elaboratable_Bind_Name {}) => tm + Elaboratable_As_Pattern _ _ _ _ (Implicit {}) => tm + Elaboratable_As_Pattern fc nameFC p t arg => Elaboratable_As_Pattern fc nameFC p t (Elaboratable_Must_Unify fc ErasedArg tm) + _ => Elaboratable_Must_Unify (getFC tm) ErasedArg tm dotErased _ _ _ _ _ tm = pure tm -- Check the rest of an application given the argument type and the @@ -569,7 +569,7 @@ mutual findBindAllExpPattern = lookup (UN Underscore) isImplicitAs : RawImp -> Bool - isImplicitAs (IAs _ _ UseLeft _ (Implicit {})) = True + isImplicitAs (Elaboratable_As_Pattern _ _ UseLeft _ (Implicit {})) = True isImplicitAs _ = False isBindAllExpPattern : Name -> Bool @@ -808,13 +808,13 @@ checkApp : {vars : _} -> (namedargs : List (Name, RawImp)) -> Maybe (Glued vars) -> Core (Term vars, Glued vars) -checkApp rig elabinfo nest env fc (IApp fc' fn arg) expargs autoargs namedargs exp +checkApp rig elabinfo nest env fc (Elaboratable_Apply fc' fn arg) expargs autoargs namedargs exp = checkApp rig elabinfo nest env fc' fn (arg :: expargs) autoargs namedargs exp -checkApp rig elabinfo nest env fc (IAutoApp fc' fn arg) expargs autoargs namedargs exp +checkApp rig elabinfo nest env fc (Elaboratable_Automatic_Apply fc' fn arg) expargs autoargs namedargs exp = checkApp rig elabinfo nest env fc' fn expargs (arg :: autoargs) namedargs exp -checkApp rig elabinfo nest env fc (INamedApp fc' fn nm arg) expargs autoargs namedargs exp +checkApp rig elabinfo nest env fc (Elaboratable_Named_Apply fc' fn nm arg) expargs autoargs namedargs exp = checkApp rig elabinfo nest env fc' fn expargs autoargs ((nm, arg) :: namedargs) exp -checkApp rig elabinfo nest env fc (IVar fc' n) expargs autoargs namedargs exp +checkApp rig elabinfo nest env fc (Elaboratable_Name fc' n) expargs autoargs namedargs exp = do (ntm, arglen, nty_in) <- getVarType elabinfo.elabMode rig nest env fc' n nty <- getNF nty_in prims <- getPrimitiveNames @@ -848,7 +848,7 @@ checkApp rig elabinfo nest env fc (IVar fc' n) expargs autoargs namedargs exp Core (Term vs, Glued vs) normalisePrims prims env res = do tm <- Normalise.normalisePrims (`boundSafe` elabMode elabinfo) - isIPrimVal + is_primitive_value (onLHS (elabMode elabinfo)) prims n expargs (fst res) env pure (fromMaybe (fst res) tm, snd res) @@ -869,7 +869,7 @@ checkApp rig elabinfo nest env fc (IVar fc' n) expargs autoargs namedargs exp -- If it's a primitive function applied to a constant on the LHS, treat it -- as an expression because we'll normalise the function away and match on -- the result - updateElabInfo prims (InLHS _) n [IPrimVal fc c] elabinfo = + updateElabInfo prims (InLHS _) n [Elaboratable_Primitive_Value fc c] elabinfo = do if isPrimName prims !(getFullName n) then pure ({ elabMode := InExpr } elabinfo) else pure elabinfo diff --git a/TTImp/Elab/Binders.idr b/TTImp/Elab/Binders.idr index 60cbd1612a..b8ef5a1c1e 100644 --- a/TTImp/Elab/Binders.idr +++ b/TTImp/Elab/Binders.idr @@ -192,7 +192,7 @@ checkLambda rig_in elabinfo nest env fc rigl info n argTy scope (Just expty_in) logTermNF "elab.binder" 10 "Lambda type" env exptynf logGlueNF "elab.binder" 10 "Got scope type" env' scopet - -- Currently, the fc a PLam holds (and that ILam gets as a consequence) + -- Currently, the fc a PLam holds (and that Elaboratable_Lambda gets as a consequence) -- is the file context of the argument to the lambda. This fits nicely -- in this exact use, but is likely a bug. log "metadata.names" 7 "checkLambda is adding ↓" diff --git a/TTImp/Elab/Case.idr b/TTImp/Elab/Case.idr index f4e6873b99..1e49e3b58f 100644 --- a/TTImp/Elab/Case.idr +++ b/TTImp/Elab/Case.idr @@ -104,10 +104,10 @@ extendNeeded b env needed findScrutinee : {vs : _} -> Env Term vs -> RawImp -> Maybe (Var vs) -findScrutinee {vs = n' :: _} (b :: bs) (IVar loc' n) +findScrutinee {vs = n' :: _} (b :: bs) (Elaboratable_Name loc' n) = if n' == n && not (isLet b) then Just first - else do MkVar p <- findScrutinee bs (IVar loc' n) + else do MkVar p <- findScrutinee bs (Elaboratable_Name loc' n) Just (MkVar (Later p)) findScrutinee _ _ = Nothing @@ -120,7 +120,7 @@ bindCaseLocals : FC -> List (Name, Maybe Name, List (Var vars)) -> bindCaseLocals fc [] args rhs = rhs bindCaseLocals fc ((n, mn, envns) :: rest) argns rhs = -- trace ("Case local " ++ show (n,mn,envns) ++ " from " ++ show argns) $ - ICaseLocal fc n (fromMaybe n mn) + Elaboratable_Case_Local_Definition fc n (fromMaybe n mn) (map getNameFrom envns) (bindCaseLocals fc rest argns rhs) where @@ -241,7 +241,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp logTermNF "elab.case" 2 "Case application" env appTm -- Start with empty nested names, since we've extended the rhs with - -- ICaseLocal so they'll get rebuilt with the right environment + -- Elaboratable_Case_Local_Definition so they'll get rebuilt with the right environment let nest' = MkNested [] ust <- get UST -- We don't want to keep rechecking delayed elaborators in the @@ -249,7 +249,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp -- we come out again, so save them let olddelayed = delayedElab ust put UST ({ delayedElab := [] } ust) - processDecl [InCase] nest' Env.empty (IDef fc casen alts') + processDecl [InCase] nest' Env.empty (Elaboratable_Definition fc casen alts') -- If there's no duplication of the scrutinee in the block, -- flag it as inlinable. @@ -275,7 +275,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp b' :: mkLocalEnv bs -- Return the original name in the environment, and what it needs to be - -- called in the case block. We need to mapping to build the ICaseLocal + -- called in the case block. We need to mapping to build the Elaboratable_Case_Local_Definition -- so that it applies to the right original variable getBindName : Int -> Name -> List Name -> (Name, Name) getBindName idx n@(UN un) vs @@ -293,7 +293,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp = let n = getBindName idx v used (ns, rest) = addEnv (idx + 1) bs (snd n :: used) ns' = n :: ns in - (ns', IAs fc EmptyFC UseLeft (snd n) (Implicit fc True) :: rest) + (ns', Elaboratable_As_Pattern fc EmptyFC UseLeft (snd n) (Implicit fc True) :: rest) -- Replace a variable in the argument list; if the reference is to -- a variable kept in the outer environment (therefore not an argument @@ -301,7 +301,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp replace : (idx : Nat) -> RawImp -> List RawImp -> List RawImp replace Z lhs (old :: xs) = let lhs' = case old of - IAs loc' nameLoc' side n _ => IAs loc' nameLoc' side n lhs + Elaboratable_As_Pattern loc' nameLoc' side n _ => Elaboratable_As_Pattern loc' nameLoc' side n lhs _ => lhs in lhs' :: xs replace (S k) lhs (x :: xs) @@ -318,17 +318,17 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp -- Names used in the pattern we're matching on, so don't bind them -- in the generated case block usedIn : RawImp -> List Name - usedIn (IBindVar _ n) = [n] - usedIn (IApp _ f a) = usedIn f ++ usedIn a - usedIn (IAs _ _ _ n a) = n :: usedIn a - usedIn (IAlternative _ _ alts) = concatMap usedIn alts + usedIn (Elaboratable_Bind_Name _ n) = [n] + usedIn (Elaboratable_Apply _ f a) = usedIn f ++ usedIn a + usedIn (Elaboratable_As_Pattern _ _ _ n a) = n :: usedIn a + usedIn (Elaboratable_Alternative _ _ alts) = concatMap usedIn alts usedIn _ = [] -- Get a name update for the LHS (so that if there's a nested data declaration -- the constructors are applied to the environment in the case block) nestLHS : FC -> (Name, (Maybe Name, List (Var vars), a)) -> (Name, RawImp) nestLHS fc (n, (mn, ns, t)) - = (n, apply (IVar fc (fromMaybe n mn)) + = (n, apply (Elaboratable_Name fc (fromMaybe n mn)) (map (const (Implicit fc False)) ns)) applyNested : NestedNames vars -> RawImp -> RawImp @@ -342,7 +342,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp updateClause casen splitOn nest env (PatClause loc' lhs rhs) = let (ns, args) = addEnv 0 env (usedIn lhs) args' = mkSplit splitOn lhs args - lhs' = apply (IVar loc' casen) args' in + lhs' = apply (Elaboratable_Name loc' casen) args' in PatClause loc' (applyNested nest lhs') (bindCaseLocals loc' (map getNestData (names nest)) ns rhs) @@ -350,12 +350,12 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp updateClause casen splitOn nest env (WithClause loc' lhs rig wval prf flags cs) = let (_, args) = addEnv 0 env (usedIn lhs) args' = mkSplit splitOn lhs args - lhs' = apply (IVar loc' casen) args' in + lhs' = apply (Elaboratable_Name loc' casen) args' in WithClause loc' (applyNested nest lhs') rig wval prf flags cs updateClause casen splitOn nest env (ImpossibleClause loc' lhs) = let (_, args) = addEnv 0 env (usedIn lhs) args' = mkSplit splitOn lhs args - lhs' = apply (IVar loc' casen) args' in + lhs' = apply (Elaboratable_Name loc' casen) args' in ImpossibleClause loc' (applyNested nest lhs') @@ -416,10 +416,10 @@ checkCase rig elabinfo nest env fc opts scr scrty_in alts exp applyTo : Defs -> RawImp -> ClosedNF -> Core RawImp applyTo defs ty (NBind fc _ (Pi _ _ Explicit _) sc) - = applyTo defs (IApp fc ty (Implicit fc False)) + = applyTo defs (Elaboratable_Apply fc ty (Implicit fc False)) !(sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder))) applyTo defs ty (NBind _ x (Pi {}) sc) - = applyTo defs (INamedApp fc ty x (Implicit fc False)) + = applyTo defs (Elaboratable_Named_Apply fc ty x (Implicit fc False)) !(sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder))) applyTo defs ty _ = pure ty @@ -439,12 +439,12 @@ checkCase rig elabinfo nest env fc opts scr scrty_in alts exp guessScrType [] = pure $ Implicit fc False guessScrType (PatClause _ x _ :: xs) = case getFn x of - IVar _ n => + Elaboratable_Name _ n => do defs <- get Ctxt [(_, (_, ty))] <- lookupTyName (mapNestedName nest n) (gamma defs) | _ => guessScrType xs Just (tyn, tyty) <- getRetTy defs !(nf defs Env.empty ty) | _ => guessScrType xs - applyTo defs (IVar fc tyn) tyty + applyTo defs (Elaboratable_Name fc tyn) tyty _ => guessScrType xs guessScrType (_ :: xs) = guessScrType xs diff --git a/TTImp/Elab/ImplicitBind.idr b/TTImp/Elab/ImplicitBind.idr index f4a3f7bdc7..0635f44a6a 100644 --- a/TTImp/Elab/ImplicitBind.idr +++ b/TTImp/Elab/ImplicitBind.idr @@ -428,7 +428,7 @@ checkBindVar rig elabinfo nest env fc nm topexp let False = case implicitMode elabinfo of PI _ => maybe False (const True) (defined nm env) _ => False - | _ => check rig elabinfo nest env (IVar fc nm) topexp + | _ => check rig elabinfo nest env (Elaboratable_Name fc nm) topexp est <- get EST let n = PV nm (defining est) noteLHSPatVar elabmode nm diff --git a/TTImp/Elab/Local.idr b/TTImp/Elab/Local.idr index 93809c8923..e1405abba1 100644 --- a/TTImp/Elab/Local.idr +++ b/TTImp/Elab/Local.idr @@ -103,7 +103,7 @@ localHelper {vars} nest env nestdecls_in func updateDataName nest (MkImpLater loc' n tycons) = MkImpLater loc' (mapNestedName nest n) tycons - updateFieldName : NestedNames vars -> IField -> IField + updateFieldName : NestedNames vars -> Elaboratable_Field -> Elaboratable_Field updateFieldName nest field = update "name" (map (mapNestedName nest)) field @@ -119,34 +119,34 @@ localHelper {vars} nest env nestdecls_in func updateRecordNS nest (Just ns) = Just $ show $ mapNestedName nest (UN $ mkUserName ns) updateName : NestedNames vars -> ImpDecl -> ImpDecl - updateName nest (IClaim claim) - = IClaim $ map {type $= updateTyName nest} claim - updateName nest (IDef loc' n cs) - = IDef loc' (mapNestedName nest n) cs - updateName nest (IData loc' vis mbt d) - = IData loc' vis mbt (updateDataName nest d) - updateName nest (IRecord loc' ns vis mbt imprecord) - = IRecord loc' (updateRecordNS nest ns) vis mbt (map (updateRecordName nest) imprecord) + updateName nest (Elaboratable_Claim claim) + = Elaboratable_Claim $ map {type $= updateTyName nest} claim + updateName nest (Elaboratable_Definition loc' n cs) + = Elaboratable_Definition loc' (mapNestedName nest n) cs + updateName nest (Elaboratable_Data_Declaration loc' vis mbt d) + = Elaboratable_Data_Declaration loc' vis mbt (updateDataName nest d) + updateName nest (Elaboratable_Record_Declaration loc' ns vis mbt imprecord) + = Elaboratable_Record_Declaration loc' (updateRecordNS nest ns) vis mbt (map (updateRecordName nest) imprecord) updateName nest i = i setPublic : ImpDecl -> ImpDecl - setPublic (IClaim claim) - = IClaim $ map {vis := Public} claim - setPublic (IData fc _ mbt d) = IData fc (specified Public) mbt d - setPublic (IRecord fc c _ mbt r) = IRecord fc c (specified Public) mbt r - setPublic (IParameters fc ps decls) - = IParameters fc ps (map setPublic decls) - setPublic (INamespace fc ps decls) - = INamespace fc ps (map setPublic decls) + setPublic (Elaboratable_Claim claim) + = Elaboratable_Claim $ map {vis := Public} claim + setPublic (Elaboratable_Data_Declaration fc _ mbt d) = Elaboratable_Data_Declaration fc (specified Public) mbt d + setPublic (Elaboratable_Record_Declaration fc c _ mbt r) = Elaboratable_Record_Declaration fc c (specified Public) mbt r + setPublic (Elaboratable_Parameter_Block fc ps decls) + = Elaboratable_Parameter_Block fc ps (map setPublic decls) + setPublic (Elaboratable_Namespace_Block fc ps decls) + = Elaboratable_Namespace_Block fc ps (map setPublic decls) setPublic d = d setErased : ImpDecl -> ImpDecl - setErased (IClaim claim) - = IClaim $ map {rig := erased} claim - setErased (IParameters fc ps decls) - = IParameters fc ps (map setErased decls) - setErased (INamespace fc ps decls) - = INamespace fc ps (map setErased decls) + setErased (Elaboratable_Claim claim) + = Elaboratable_Claim $ map {rig := erased} claim + setErased (Elaboratable_Parameter_Block fc ps decls) + = Elaboratable_Parameter_Block fc ps (map setErased decls) + setErased (Elaboratable_Namespace_Block fc ps decls) + = Elaboratable_Namespace_Block fc ps (map setErased decls) setErased d = d export diff --git a/TTImp/Elab/Quote.idr b/TTImp/Elab/Quote.idr index bcd0d45091..72b5397d03 100644 --- a/TTImp/Elab/Quote.idr +++ b/TTImp/Elab/Quote.idr @@ -25,52 +25,52 @@ mutual {auto u : Ref UST UState} -> RawImp -> Core RawImp - getUnquote (IPi fc c p n arg ret) - = pure $ IPi fc c p n !(getUnquote arg) !(getUnquote ret) - getUnquote (ILam fc c p n arg sc) - = pure $ ILam fc c p n !(getUnquote arg) !(getUnquote sc) - getUnquote (ILet fc lhsFC c n ty val sc) - = pure $ ILet fc lhsFC c n !(getUnquote ty) !(getUnquote val) !(getUnquote sc) - getUnquote (ICase fc opts sc ty cs) - = pure $ ICase fc opts + getUnquote (Elaboratable_Dependent_Function_Type fc c p n arg ret) + = pure $ Elaboratable_Dependent_Function_Type fc c p n !(getUnquote arg) !(getUnquote ret) + getUnquote (Elaboratable_Lambda fc c p n arg sc) + = pure $ Elaboratable_Lambda fc c p n !(getUnquote arg) !(getUnquote sc) + getUnquote (Elaboratable_Binding fc lhsFC c n ty val sc) + = pure $ Elaboratable_Binding fc lhsFC c n !(getUnquote ty) !(getUnquote val) !(getUnquote sc) + getUnquote (Elaboratable_Case fc opts sc ty cs) + = pure $ Elaboratable_Case fc opts !(getUnquote sc) !(getUnquote ty) !(traverse getUnquoteClause cs) - getUnquote (ILocal fc ds sc) - = pure $ ILocal fc !(traverse getUnquoteDecl ds) !(getUnquote sc) - getUnquote (IUpdate fc ds sc) - = pure $ IUpdate fc !(traverse getUnquoteUpdate ds) !(getUnquote sc) - getUnquote (IApp fc f a) - = pure $ IApp fc !(getUnquote f) !(getUnquote a) - getUnquote (IAutoApp fc f a) - = pure $ IAutoApp fc !(getUnquote f) !(getUnquote a) - getUnquote (INamedApp fc f n a) - = pure $ INamedApp fc !(getUnquote f) n !(getUnquote a) - getUnquote (IWithApp fc f a) - = pure $ IWithApp fc !(getUnquote f) !(getUnquote a) - getUnquote (IAlternative fc at as) - = pure $ IAlternative fc at !(traverse getUnquote as) - getUnquote (IRewrite fc f a) - = pure $ IRewrite fc !(getUnquote f) !(getUnquote a) - getUnquote (ICoerced fc t) - = pure $ ICoerced fc !(getUnquote t) - getUnquote (IBindHere fc m t) - = pure $ IBindHere fc m !(getUnquote t) - getUnquote (IAs fc nameFC u nm t) - = pure $ IAs fc nameFC u nm !(getUnquote t) - getUnquote (IMustUnify fc r t) - = pure $ IMustUnify fc r !(getUnquote t) - getUnquote (IDelayed fc r t) - = pure $ IDelayed fc r !(getUnquote t) - getUnquote (IDelay fc t) - = pure $ IDelay fc !(getUnquote t) - getUnquote (IForce fc t) - = pure $ IForce fc !(getUnquote t) - getUnquote (IQuote fc t) - = pure $ IQuote fc !(getUnquote t) - getUnquote (IUnquote fc tm) + getUnquote (Elaboratable_Local_Definitions fc ds sc) + = pure $ Elaboratable_Local_Definitions fc !(traverse getUnquoteDecl ds) !(getUnquote sc) + getUnquote (Elaboratable_Record_Update fc ds sc) + = pure $ Elaboratable_Record_Update fc !(traverse getUnquoteUpdate ds) !(getUnquote sc) + getUnquote (Elaboratable_Apply fc f a) + = pure $ Elaboratable_Apply fc !(getUnquote f) !(getUnquote a) + getUnquote (Elaboratable_Automatic_Apply fc f a) + = pure $ Elaboratable_Automatic_Apply fc !(getUnquote f) !(getUnquote a) + getUnquote (Elaboratable_Named_Apply fc f n a) + = pure $ Elaboratable_Named_Apply fc !(getUnquote f) n !(getUnquote a) + getUnquote (Elaboratable_With_Apply fc f a) + = pure $ Elaboratable_With_Apply fc !(getUnquote f) !(getUnquote a) + getUnquote (Elaboratable_Alternative fc at as) + = pure $ Elaboratable_Alternative fc at !(traverse getUnquote as) + getUnquote (Elaboratable_Rewrite fc f a) + = pure $ Elaboratable_Rewrite fc !(getUnquote f) !(getUnquote a) + getUnquote (Elaboratable_Coerced fc t) + = pure $ Elaboratable_Coerced fc !(getUnquote t) + getUnquote (Elaboratable_Bind_Here fc m t) + = pure $ Elaboratable_Bind_Here fc m !(getUnquote t) + getUnquote (Elaboratable_As_Pattern fc nameFC u nm t) + = pure $ Elaboratable_As_Pattern fc nameFC u nm !(getUnquote t) + getUnquote (Elaboratable_Must_Unify fc r t) + = pure $ Elaboratable_Must_Unify fc r !(getUnquote t) + getUnquote (Elaboratable_Delayed_Type fc r t) + = pure $ Elaboratable_Delayed_Type fc r !(getUnquote t) + getUnquote (Elaboratable_Delay fc t) + = pure $ Elaboratable_Delay fc !(getUnquote t) + getUnquote (Elaboratable_Force fc t) + = pure $ Elaboratable_Force fc !(getUnquote t) + getUnquote (Elaboratable_Quote fc t) + = pure $ Elaboratable_Quote fc !(getUnquote t) + getUnquote (Elaboratable_Unquote fc tm) = do qv <- genVarName "q" update Unq ((qv, fc, tm) ::) - pure (IUnquote fc (IVar fc qv)) -- turned into just qv when reflecting + pure (Elaboratable_Unquote fc (Elaboratable_Name fc qv)) -- turned into just qv when reflecting getUnquote tm = pure tm getUnquoteClause : {auto c : Ref Ctxt Defs} -> @@ -95,10 +95,10 @@ mutual getUnquoteUpdate : {auto c : Ref Ctxt Defs} -> {auto q : Ref Unq (List (Name, FC, RawImp))} -> {auto u : Ref UST UState} -> - IFieldUpdate -> - Core IFieldUpdate - getUnquoteUpdate (ISetField p t) = pure $ ISetField p !(getUnquote t) - getUnquoteUpdate (ISetFieldApp p t) = pure $ ISetFieldApp p !(getUnquote t) + Elaboratable_Field_Update -> + Core Elaboratable_Field_Update + getUnquoteUpdate (Elaboratable_Set_Field p t) = pure $ Elaboratable_Set_Field p !(getUnquote t) + getUnquoteUpdate (Elaboratable_Apply_To_Field p t) = pure $ Elaboratable_Apply_To_Field p !(getUnquote t) getUnquoteRecord : {auto c : Ref Ctxt Defs} -> {auto q : Ref Unq (List (Name, FC, RawImp))} -> @@ -126,22 +126,22 @@ mutual {auto u : Ref UST UState} -> ImpDecl -> Core ImpDecl - getUnquoteDecl (IClaim (MkWithData fc (MkIClaimData c v opts ty))) - = pure $ IClaim (MkWithData fc (MkIClaimData c v opts !(traverse getUnquote ty))) - getUnquoteDecl (IData fc v mbt d) - = pure $ IData fc v mbt !(getUnquoteData d) - getUnquoteDecl (IDef fc v d) - = pure $ IDef fc v !(traverse getUnquoteClause d) - getUnquoteDecl (IParameters fc ps ds) - = pure $ IParameters fc -- We also unquote default arguments here too + getUnquoteDecl (Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data c v opts ty))) + = pure $ Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data c v opts !(traverse getUnquote ty))) + getUnquoteDecl (Elaboratable_Data_Declaration fc v mbt d) + = pure $ Elaboratable_Data_Declaration fc v mbt !(getUnquoteData d) + getUnquoteDecl (Elaboratable_Definition fc v d) + = pure $ Elaboratable_Definition fc v !(traverse getUnquoteClause d) + getUnquoteDecl (Elaboratable_Parameter_Block fc ps ds) + = pure $ Elaboratable_Parameter_Block fc -- We also unquote default arguments here too !(traverseList1 (traverse (traverse getUnquote)) ps) !(traverse getUnquoteDecl ds) - getUnquoteDecl (IRecord fc ns v mbt d) - = pure $ IRecord fc ns v mbt !(traverse getUnquoteRecord d) - getUnquoteDecl (INamespace fc ns ds) - = pure $ INamespace fc ns !(traverse getUnquoteDecl ds) - getUnquoteDecl (ITransform fc n l r) - = pure $ ITransform fc n !(getUnquote l) !(getUnquote r) + getUnquoteDecl (Elaboratable_Record_Declaration fc ns v mbt d) + = pure $ Elaboratable_Record_Declaration fc ns v mbt !(traverse getUnquoteRecord d) + getUnquoteDecl (Elaboratable_Namespace_Block fc ns ds) + = pure $ Elaboratable_Namespace_Block fc ns !(traverse getUnquoteDecl ds) + getUnquoteDecl (Elaboratable_Transformation fc n l r) + = pure $ Elaboratable_Transformation fc n !(getUnquote l) !(getUnquote r) getUnquoteDecl d = pure d bindUnqs : {vars : _} -> diff --git a/TTImp/Elab/Record.idr b/TTImp/Elab/Record.idr index 7f1694d0fe..15da45deb1 100644 --- a/TTImp/Elab/Record.idr +++ b/TTImp/Elab/Record.idr @@ -52,11 +52,11 @@ Show Rec where toLHS' : FC -> Rec -> (Maybe Name, RawImp) toLHS' loc (Field mn@(Just _) n _) - = (mn, IAs loc (virtualiseFC loc) UseRight (UN $ Basic n) (Implicit loc True)) -toLHS' loc (Field mn n _) = (mn, IBindVar (virtualiseFC loc) (UN $ Basic n)) + = (mn, Elaboratable_As_Pattern loc (virtualiseFC loc) UseRight (UN $ Basic n) (Implicit loc True)) +toLHS' loc (Field mn n _) = (mn, Elaboratable_Bind_Name (virtualiseFC loc) (UN $ Basic n)) toLHS' loc (Constr mn con args) = let args' = map (toLHS' loc . snd) args in - (mn, gapply (IVar loc con) args') + (mn, gapply (Elaboratable_Name loc con) args') toLHS : FC -> Rec -> RawImp toLHS fc r = snd (toLHS' fc r) @@ -65,7 +65,7 @@ toRHS' : FC -> Rec -> (Maybe Name, RawImp) toRHS' loc (Field mn _ val) = (mn, val) toRHS' loc (Constr mn con args) = let args' = map (toRHS' loc . snd) args in - (mn, gapply (IVar loc con) args') + (mn, gapply (Elaboratable_Name loc con) args') toRHS : FC -> Rec -> RawImp toRHS fc r = snd (toRHS' fc r) @@ -145,7 +145,7 @@ findPath loc (p :: ps) full (Just tyn) val (Field mn n v) -- If other types depend on that implicit argument, leave it as _ by default let arg = case (flip contains tyArgs) <$> imp of Just True => Implicit loc False - _ => IVar (virtualiseFC loc) (UN $ Basic fldn) + _ => Elaboratable_Name (virtualiseFC loc) (UN $ Basic fldn) pure ((p, Field imp fldn arg) :: args') findPath loc (p :: ps) full tyn val (Constr mn con args) @@ -161,19 +161,19 @@ findPath loc (p :: ps) full tyn val (Constr mn con args) getSides : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> IFieldUpdate -> Name -> RawImp -> Rec -> + FC -> Elaboratable_Field_Update -> Name -> RawImp -> Rec -> Core Rec -getSides loc (ISetField path val) tyn orig rec +getSides loc (Elaboratable_Set_Field path val) tyn orig rec -- update 'rec' so that 'path' is accessible on the lhs and rhs, -- then set the path on the rhs to 'val' = findPath loc path path (Just tyn) (const val) rec -getSides loc (ISetFieldApp path val) tyn orig rec +getSides loc (Elaboratable_Apply_To_Field path val) tyn orig rec = findPath loc path path (Just tyn) - (\n => apply val [IVar (virtualiseFC loc) (UN $ Basic n)]) rec + (\n => apply val [Elaboratable_Name (virtualiseFC loc) (UN $ Basic n)]) rec getAllSides : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> List IFieldUpdate -> Name -> + FC -> List Elaboratable_Field_Update -> Name -> RawImp -> Rec -> Core Rec getAllSides loc [] tyn orig rec = pure rec @@ -181,7 +181,7 @@ getAllSides loc (u :: upds) tyn orig rec = getAllSides loc upds tyn orig !(getSides loc u tyn orig rec) checkForDuplicates : - List IFieldUpdate -> + List Elaboratable_Field_Update -> (seen, dups : SortedSet (List String)) -> SortedSet (List String) checkForDuplicates [] seen dups = dups @@ -198,7 +198,7 @@ recUpdate : {vars : _} -> {auto u : Ref UST UState} -> RigCount -> ElabInfo -> FC -> NestedNames vars -> Env Term vars -> - List IFieldUpdate -> + List Elaboratable_Field_Update -> (rec : RawImp) -> (grecty : Glued vars) -> Core RawImp recUpdate rigc elabinfo iloc nest env flds rec grecty @@ -211,8 +211,8 @@ recUpdate rigc elabinfo iloc nest env flds rec grecty | Nothing => throw (RecordTypeNeeded iloc env) fldn <- genFieldName "__fld" sides <- getAllSides iloc flds rectyn rec - (Field Nothing fldn (IVar vloc (UN $ Basic fldn))) - pure $ ICase vloc [] rec (Implicit vloc False) [mkClause sides] + (Field Nothing fldn (Elaboratable_Name vloc (UN $ Basic fldn))) + pure $ Elaboratable_Case vloc [] rec (Implicit vloc False) [mkClause sides] where vloc : FC vloc = virtualiseFC iloc @@ -239,7 +239,7 @@ checkUpdate : {vars : _} -> {auto o : Ref ROpts REPLOpts} -> RigCount -> ElabInfo -> NestedNames vars -> Env Term vars -> - FC -> List IFieldUpdate -> RawImp -> Maybe (Glued vars) -> + FC -> List Elaboratable_Field_Update -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkUpdate rig elabinfo nest env fc upds rec expected = do recty <- case expected of diff --git a/TTImp/Elab/Rewrite.idr b/TTImp/Elab/Rewrite.idr index 7c901ed2bd..1c283a462a 100644 --- a/TTImp/Elab/Rewrite.idr +++ b/TTImp/Elab/Rewrite.idr @@ -144,9 +144,9 @@ checkRewrite {vars} rigc elabinfo nest env ifc rule tm (Just expected) inScope {e=e'} vfc env' $ \e'' => let offset = mkSizeOf [rname, pname] in check {e = e''} rigc elabinfo (weakenNs offset nest) env' - (apply (IVar vfc lemma.name) - [ IVar vfc pname - , IVar vfc rname + (apply (Elaboratable_Name vfc lemma.name) + [ Elaboratable_Name vfc pname + , Elaboratable_Name vfc rname , tm ]) (Just (gnf env' (weakenNs offset expTy))) rwty <- getTerm grwty diff --git a/TTImp/Elab/Term.idr b/TTImp/Elab/Term.idr index 1ee5becdd6..87db168181 100644 --- a/TTImp/Elab/Term.idr +++ b/TTImp/Elab/Term.idr @@ -42,27 +42,27 @@ insertImpLam {vars} env tm (Just ty) = bindLam tm ty -- If we can decide whether we need implicit lambdas without looking -- at the normal form, do so bindLamTm : RawImp -> Term vs -> Core (Maybe RawImp) - bindLamTm tm@(ILam _ _ Implicit _ _ _) (Bind fc n (Pi _ _ Implicit _) sc) + bindLamTm tm@(Elaboratable_Lambda _ _ Implicit _ _ _) (Bind fc n (Pi _ _ Implicit _) sc) = pure (Just tm) - bindLamTm tm@(ILam _ _ AutoImplicit _ _ _) (Bind fc n (Pi _ _ AutoImplicit _) sc) + bindLamTm tm@(Elaboratable_Lambda _ _ AutoImplicit _ _ _) (Bind fc n (Pi _ _ AutoImplicit _) sc) = pure (Just tm) - bindLamTm tm@(ILam _ _ (DefImplicit _) _ _ _) (Bind fc n (Pi _ _ (DefImplicit _) _) sc) + bindLamTm tm@(Elaboratable_Lambda _ _ (DefImplicit _) _ _ _) (Bind fc n (Pi _ _ (DefImplicit _) _) sc) = pure (Just tm) bindLamTm tm (Bind fc n (Pi _ c Implicit ty) sc) = do n' <- genVarName (nameRoot n) Just sc' <- bindLamTm tm sc | Nothing => pure Nothing - pure $ Just (ILam fc c Implicit (Just n') (Implicit fc False) sc') + pure $ Just (Elaboratable_Lambda fc c Implicit (Just n') (Implicit fc False) sc') bindLamTm tm (Bind fc n (Pi _ c AutoImplicit ty) sc) = do n' <- genVarName (nameRoot n) Just sc' <- bindLamTm tm sc | Nothing => pure Nothing - pure $ Just (ILam fc c AutoImplicit (Just n') (Implicit fc False) sc') + pure $ Just (Elaboratable_Lambda fc c AutoImplicit (Just n') (Implicit fc False) sc') bindLamTm tm (Bind fc n (Pi _ c (DefImplicit _) ty) sc) = do n' <- genVarName (nameRoot n) Just sc' <- bindLamTm tm sc | Nothing => pure Nothing - pure $ Just (ILam fc c (DefImplicit (Implicit fc False)) + pure $ Just (Elaboratable_Lambda fc c (DefImplicit (Implicit fc False)) (Just n') (Implicit fc False) sc') bindLamTm tm exp = case getFn exp of @@ -72,28 +72,28 @@ insertImpLam {vars} env tm (Just ty) = bindLam tm ty _ => pure $ Just tm bindLamNF : RawImp -> NF vars -> Core RawImp - bindLamNF tm@(ILam _ _ Implicit _ _ _) (NBind fc n (Pi _ _ Implicit _) sc) + bindLamNF tm@(Elaboratable_Lambda _ _ Implicit _ _ _) (NBind fc n (Pi _ _ Implicit _) sc) = pure tm - bindLamNF tm@(ILam _ _ AutoImplicit _ _ _) (NBind fc n (Pi _ _ AutoImplicit _) sc) + bindLamNF tm@(Elaboratable_Lambda _ _ AutoImplicit _ _ _) (NBind fc n (Pi _ _ AutoImplicit _) sc) = pure tm bindLamNF tm (NBind fc n (Pi fc' c Implicit ty) sc) = do defs <- get Ctxt n' <- genVarName (nameRoot n) sctm <- sc defs (toClosure defaultOpts env (Ref fc Bound n')) sc' <- bindLamNF tm sctm - pure $ ILam fc c Implicit (Just n') (Implicit fc False) sc' + pure $ Elaboratable_Lambda fc c Implicit (Just n') (Implicit fc False) sc' bindLamNF tm (NBind fc n (Pi fc' c AutoImplicit ty) sc) = do defs <- get Ctxt n' <- genVarName (nameRoot n) sctm <- sc defs (toClosure defaultOpts env (Ref fc Bound n')) sc' <- bindLamNF tm sctm - pure $ ILam fc c AutoImplicit (Just n') (Implicit fc False) sc' + pure $ Elaboratable_Lambda fc c AutoImplicit (Just n') (Implicit fc False) sc' bindLamNF tm (NBind fc n (Pi _ c (DefImplicit _) ty) sc) = do defs <- get Ctxt n' <- genVarName (nameRoot n) sctm <- sc defs (toClosure defaultOpts env (Ref fc Bound n')) sc' <- bindLamNF tm sctm - pure $ ILam fc c (DefImplicit (Implicit fc False)) + pure $ Elaboratable_Lambda fc c (DefImplicit (Implicit fc False)) (Just n') (Implicit fc False) sc' bindLamNF tm sc = pure tm @@ -119,52 +119,52 @@ checkTerm : {vars : _} -> RigCount -> ElabInfo -> NestedNames vars -> Env Term vars -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) -checkTerm rig elabinfo nest env (IVar fc n) exp +checkTerm rig elabinfo nest env (Elaboratable_Name fc n) exp = -- It may actually turn out to be an application, if the expected -- type is expecting an implicit argument, so check it as an -- application with no arguments - checkApp rig elabinfo nest env fc (IVar fc n) [] [] [] exp -checkTerm rig elabinfo nest env (IPi fc r p Nothing argTy retTy) exp + checkApp rig elabinfo nest env fc (Elaboratable_Name fc n) [] [] [] exp +checkTerm rig elabinfo nest env (Elaboratable_Dependent_Function_Type fc r p Nothing argTy retTy) exp = do n <- case p of Explicit => genVarName "arg" Implicit => genVarName "impArg" AutoImplicit => genVarName "conArg" (DefImplicit _) => genVarName "defArg" checkPi rig elabinfo nest env fc r p n argTy retTy exp -checkTerm rig elabinfo nest env (IPi fc r p (Just (UN Underscore)) argTy retTy) exp - = checkTerm rig elabinfo nest env (IPi fc r p Nothing argTy retTy) exp -checkTerm rig elabinfo nest env (IPi fc r p (Just n) argTy retTy) exp +checkTerm rig elabinfo nest env (Elaboratable_Dependent_Function_Type fc r p (Just (UN Underscore)) argTy retTy) exp + = checkTerm rig elabinfo nest env (Elaboratable_Dependent_Function_Type fc r p Nothing argTy retTy) exp +checkTerm rig elabinfo nest env (Elaboratable_Dependent_Function_Type fc r p (Just n) argTy retTy) exp = checkPi rig elabinfo nest env fc r p n argTy retTy exp -checkTerm rig elabinfo nest env (ILam fc r p (Just n) argTy scope) exp +checkTerm rig elabinfo nest env (Elaboratable_Lambda fc r p (Just n) argTy scope) exp = checkLambda rig elabinfo nest env fc r p n argTy scope exp -checkTerm rig elabinfo nest env (ILam fc r p Nothing argTy scope) exp +checkTerm rig elabinfo nest env (Elaboratable_Lambda fc r p Nothing argTy scope) exp = do n <- genVarName "_" checkLambda rig elabinfo nest env fc r p n argTy scope exp -checkTerm rig elabinfo nest env (ILet fc lhsFC r n nTy nVal scope) exp +checkTerm rig elabinfo nest env (Elaboratable_Binding fc lhsFC r n nTy nVal scope) exp = checkLet rig elabinfo nest env fc lhsFC r n nTy nVal scope exp -checkTerm rig elabinfo nest env (ICase fc opts scr scrty alts) exp +checkTerm rig elabinfo nest env (Elaboratable_Case fc opts scr scrty alts) exp = checkCase rig elabinfo nest env fc opts scr scrty alts exp -checkTerm rig elabinfo nest env (ILocal fc nested scope) exp +checkTerm rig elabinfo nest env (Elaboratable_Local_Definitions fc nested scope) exp = checkLocal rig elabinfo nest env fc nested scope exp -checkTerm rig elabinfo nest env (ICaseLocal fc uname iname args scope) exp +checkTerm rig elabinfo nest env (Elaboratable_Case_Local_Definition fc uname iname args scope) exp = checkCaseLocal rig elabinfo nest env fc uname iname args scope exp -checkTerm rig elabinfo nest env (IUpdate fc upds rec) exp +checkTerm rig elabinfo nest env (Elaboratable_Record_Update fc upds rec) exp = checkUpdate rig elabinfo nest env fc upds rec exp -checkTerm rig elabinfo nest env (IApp fc fn arg) exp +checkTerm rig elabinfo nest env (Elaboratable_Apply fc fn arg) exp = checkApp rig elabinfo nest env fc fn [arg] [] [] exp -checkTerm rig elabinfo nest env (IAutoApp fc fn arg) exp +checkTerm rig elabinfo nest env (Elaboratable_Automatic_Apply fc fn arg) exp = checkApp rig elabinfo nest env fc fn [] [arg] [] exp -checkTerm rig elabinfo nest env (IWithApp fc fn arg) exp +checkTerm rig elabinfo nest env (Elaboratable_With_Apply fc fn arg) exp = throw (GenericMsg fc "with application not implemented yet") -checkTerm rig elabinfo nest env (INamedApp fc fn nm arg) exp +checkTerm rig elabinfo nest env (Elaboratable_Named_Apply fc fn nm arg) exp = checkApp rig elabinfo nest env fc fn [] [] [(nm, arg)] exp -checkTerm rig elabinfo nest env (ISearch fc depth) (Just gexpty) +checkTerm rig elabinfo nest env (Elaboratable_Search fc depth) (Just gexpty) = do est <- get EST nm <- genName "search" expty <- getTerm gexpty sval <- searchVar fc rig depth (Resolved (defining est)) env nest nm expty pure (sval, gexpty) -checkTerm rig elabinfo nest env (ISearch fc depth) Nothing +checkTerm rig elabinfo nest env (Elaboratable_Search fc depth) Nothing = do est <- get EST nmty <- genName "searchTy" u <- uniVar fc @@ -172,45 +172,45 @@ checkTerm rig elabinfo nest env (ISearch fc depth) Nothing nm <- genName "search" sval <- searchVar fc rig depth (Resolved (defining est)) env nest nm ty pure (sval, gnf env ty) -checkTerm rig elabinfo nest env (IAlternative fc uniq alts) exp +checkTerm rig elabinfo nest env (Elaboratable_Alternative fc uniq alts) exp = checkAlternative rig elabinfo nest env fc uniq alts exp -checkTerm rig elabinfo nest env (IRewrite fc rule tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Rewrite fc rule tm) exp = checkRewrite rig elabinfo nest env fc rule tm exp -checkTerm rig elabinfo nest env (ICoerced fc tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Coerced fc tm) exp = checkTerm rig elabinfo nest env tm exp -checkTerm rig elabinfo nest env (IBindHere fc binder sc) exp +checkTerm rig elabinfo nest env (Elaboratable_Bind_Here fc binder sc) exp = checkBindHere rig elabinfo nest env fc binder sc exp -checkTerm rig elabinfo nest env (IBindVar fc n) exp +checkTerm rig elabinfo nest env (Elaboratable_Bind_Name fc n) exp = checkBindVar rig elabinfo nest env fc n exp -checkTerm rig elabinfo nest env (IAs fc nameFC side n_in tm) exp +checkTerm rig elabinfo nest env (Elaboratable_As_Pattern fc nameFC side n_in tm) exp = checkAs rig elabinfo nest env fc nameFC side n_in tm exp -checkTerm rig elabinfo nest env (IMustUnify fc reason tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Must_Unify fc reason tm) exp = checkDot rig elabinfo nest env fc reason tm exp -checkTerm rig elabinfo nest env (IDelayed fc r tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Delayed_Type fc r tm) exp = checkDelayed rig elabinfo nest env fc r tm exp -checkTerm rig elabinfo nest env (IDelay fc tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Delay fc tm) exp = checkDelay rig elabinfo nest env fc tm exp -checkTerm rig elabinfo nest env (IForce fc tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Force fc tm) exp = checkForce rig elabinfo nest env fc tm exp -checkTerm rig elabinfo nest env (IQuote fc tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Quote fc tm) exp = checkQuote rig elabinfo nest env fc tm exp -checkTerm rig elabinfo nest env (IQuoteName fc n) exp +checkTerm rig elabinfo nest env (Elaboratable_Quote_Name fc n) exp = checkQuoteName rig elabinfo nest env fc n exp -checkTerm rig elabinfo nest env (IQuoteDecl fc ds) exp +checkTerm rig elabinfo nest env (Elaboratable_Quote_Declarations fc ds) exp = checkQuoteDecl rig elabinfo nest env fc ds exp -checkTerm rig elabinfo nest env (IUnquote fc tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Unquote fc tm) exp = throw (GenericMsg fc "Can't escape outside a quoted term") -checkTerm rig elabinfo nest env (IRunElab fc re tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Run_Elaborator fc re tm) exp = checkRunElab rig elabinfo nest env fc re tm exp -checkTerm {vars} rig elabinfo nest env (IPrimVal fc c) exp +checkTerm {vars} rig elabinfo nest env (Elaboratable_Primitive_Value fc c) exp = do let (cval, cty) = checkPrim {vars} fc c checkExp rig elabinfo env fc cval (gnf env cty) exp -checkTerm rig elabinfo nest env (IType fc) exp +checkTerm rig elabinfo nest env (Elaboratable_Type_Universe fc) exp = do u <- uniVar fc checkExp rig elabinfo env fc (TType fc u) (gType fc u) exp -checkTerm rig elabinfo nest env (IHole fc str) exp +checkTerm rig elabinfo nest env (Elaboratable_Hole fc str) exp = checkHole rig elabinfo nest env fc (Basic str) exp -checkTerm rig elabinfo nest env (IUnifyLog fc lvl tm) exp +checkTerm rig elabinfo nest env (Elaboratable_Unification_Log fc lvl tm) exp = withLogLevel lvl $ check rig elabinfo nest env tm exp checkTerm rig elabinfo nest env (Implicit fc b) (Just gexpty) = do nm <- genName "_" @@ -232,7 +232,7 @@ checkTerm rig elabinfo nest env (Implicit fc b) Nothing when (b && bindingVars elabinfo) $ update EST $ addBindIfUnsolved nm fc rig Explicit env metaval ty pure (metaval, gnf env ty) -checkTerm rig elabinfo nest env (IWithUnambigNames fc ns rhs) exp +checkTerm rig elabinfo nest env (Elaboratable_With_Unambiguous_Names fc ns rhs) exp = do -- enter the scope -> add unambiguous names est <- get EST rns <- resolveNames fc ns @@ -283,14 +283,14 @@ checkTerm rig elabinfo nest env (IWithUnambigNames fc ns rhs) exp -- Core (Term vars, Glued vars) -- If we've just inserted an implicit coercion (in practice, that's either -- a force or delay) then check the term with any further insertions -TTImp.Elab.Check.check rigc elabinfo nest env (ICoerced fc tm) exp +TTImp.Elab.Check.check rigc elabinfo nest env (Elaboratable_Coerced fc tm) exp = checkImp rigc elabinfo nest env tm exp -- Don't add implicits/coercions on local blocks or record updates -TTImp.Elab.Check.check rigc elabinfo nest env tm@(ILet {}) exp +TTImp.Elab.Check.check rigc elabinfo nest env tm@(Elaboratable_Binding {}) exp = checkImp rigc elabinfo nest env tm exp -TTImp.Elab.Check.check rigc elabinfo nest env tm@(ILocal {}) exp +TTImp.Elab.Check.check rigc elabinfo nest env tm@(Elaboratable_Local_Definitions {}) exp = checkImp rigc elabinfo nest env tm exp -TTImp.Elab.Check.check rigc elabinfo nest env tm@(IUpdate {}) exp +TTImp.Elab.Check.check rigc elabinfo nest env tm@(Elaboratable_Record_Update {}) exp = checkImp rigc elabinfo nest env tm exp TTImp.Elab.Check.check rigc elabinfo nest env tm_in exp = do tm <- expandAmbigName (elabMode elabinfo) nest env tm_in [] tm_in exp diff --git a/TTImp/Impossible.idr b/TTImp/Impossible.idr index 23ca46626b..d508243eb4 100644 --- a/TTImp/Impossible.idr +++ b/TTImp/Impossible.idr @@ -188,21 +188,21 @@ mutual (autoargs : List (WithFC RawImp)) -> (namedargs : List (Name, WithFC RawImp)) -> Core ClosedTerm - go (IVar fc n) exps autos named + go (Elaboratable_Name fc n) exps autos named = buildApp fc n mty exps autos named - go (IAs fc fc' u n pat) exps autos named + go (Elaboratable_As_Pattern fc fc' u n pat) exps autos named = go pat exps autos named - go (IApp fc fn arg) exps autos named + go (Elaboratable_Apply fc fn arg) exps autos named = go fn (MkFCVal fc arg :: exps) autos named - go (IWithApp fc fn arg) exps autos named + go (Elaboratable_With_Apply fc fn arg) exps autos named = go fn (MkFCVal fc arg :: exps) autos named - go (IAutoApp fc fn arg) exps autos named + go (Elaboratable_Automatic_Apply fc fn arg) exps autos named = go fn exps (MkFCVal fc arg :: autos) named - go (INamedApp fc fn nm arg) exps autos named + go (Elaboratable_Named_Apply fc fn nm arg) exps autos named = go fn exps autos ((nm, MkFCVal fc arg) :: named) - go (IMustUnify fc r tm) exps autos named + go (Elaboratable_Must_Unify fc r tm) exps autos named = Erased fc . Dotted <$> go tm exps autos named - go (IPrimVal fc c) _ _ _ + go (Elaboratable_Primitive_Value fc c) _ _ _ = do let tm = PrimVal fc c True <- isValidPrimType | _ => throw $ GenericMsg fc "\{show tm} does not match expected type" @@ -217,7 +217,7 @@ mutual (Nothing, NType {}) => pure True (Just t1, NPrimVal _ (PrT t2)) => pure (t1 == t2) _ => pure False - go (IType fc) _ _ _ + go (Elaboratable_Type_Universe fc) _ _ _ = do defs <- get Ctxt Just (NType {}) <- traverseOpt (evalClosure defs) mty | _ => throw $ GenericMsg fc "Type does not match expected type" @@ -225,10 +225,10 @@ mutual -- We're taking UniqueDefault here, _and_ we're falling through to error otherwise, which is sketchy. -- One option is to try each and emit an AmbiguousElab? We maybe should respect `UniqueDefault` if there -- is no evidence (mty), but we should _try_ to resolve here if there is an mty. - go (IAlternative _ (UniqueDefault tm) _) exps autos named + go (Elaboratable_Alternative _ (UniqueDefault tm) _) exps autos named = go tm exps autos named go (Implicit fc _) _ _ _ = nextVar fc - go (IBindVar fc _) _ _ _ = nextVar fc + go (Elaboratable_Bind_Name fc _) _ _ _ = nextVar fc go tm _ _ _ = do tm' <- pterm (map defaultKindedName tm) -- hack throw $ GenericMsg (getFC tm) "Unsupported term in impossible clause: \{show tm'}" @@ -254,18 +254,18 @@ getImpossibleTerm env nest tm else Implicit fc False :: addEnv fc env expandNest : RawImp -> RawImp - expandNest (IVar fc n) + expandNest (Elaboratable_Name fc n) = case lookup n (names nest) of - Just (Just n', _, _) => IVar fc n' - _ => IVar fc n + Just (Just n', _, _) => Elaboratable_Name fc n' + _ => Elaboratable_Name fc n expandNest tm = tm -- Need to apply the function to the surrounding environment, and update -- the name to the proper one from the nested names map applyEnv : RawImp -> RawImp - applyEnv (IApp fc fn arg) = IApp fc (applyEnv fn) arg - applyEnv (IWithApp fc fn arg) = IWithApp fc (applyEnv fn) arg - applyEnv (IAutoApp fc fn arg) = IAutoApp fc (applyEnv fn) arg - applyEnv (INamedApp fc fn n arg) - = INamedApp fc (applyEnv fn) n arg + applyEnv (Elaboratable_Apply fc fn arg) = Elaboratable_Apply fc (applyEnv fn) arg + applyEnv (Elaboratable_With_Apply fc fn arg) = Elaboratable_With_Apply fc (applyEnv fn) arg + applyEnv (Elaboratable_Automatic_Apply fc fn arg) = Elaboratable_Automatic_Apply fc (applyEnv fn) arg + applyEnv (Elaboratable_Named_Apply fc fn n arg) + = Elaboratable_Named_Apply fc (applyEnv fn) n arg applyEnv tm = apply (expandNest tm) (addEnv (getFC tm) env) diff --git a/TTImp/Interactive/CaseSplit.idr b/TTImp/Interactive/CaseSplit.idr index 2a34be9341..3feae3a945 100644 --- a/TTImp/Interactive/CaseSplit.idr +++ b/TTImp/Interactive/CaseSplit.idr @@ -134,8 +134,8 @@ expandCon fc usedvars con = do defs <- get Ctxt Just ty <- lookupTyExact con (gamma defs) | Nothing => undefinedName fc con - pure (apply (IVar fc con) - (map (IBindVar fc . UN . Basic) + pure (apply (Elaboratable_Name fc con) + (map (Elaboratable_Bind_Name fc . UN . Basic) !(getArgNames defs [] usedvars Env.empty !(nf defs Env.empty ty)))) @@ -143,25 +143,25 @@ updateArg : {auto c : Ref Ctxt Defs} -> List Name -> -- all the variable names (var : Name) -> (con : Name) -> RawImp -> Core RawImp -updateArg allvars var con (IVar fc n) +updateArg allvars var con (Elaboratable_Name fc n) = if n `elem` allvars then if n == var then expandCon fc (filter (/= n) allvars) con else pure $ Implicit fc True - else pure $ IVar fc n -updateArg allvars var con (IApp fc f a) - = pure $ IApp fc !(updateArg allvars var con f) + else pure $ Elaboratable_Name fc n +updateArg allvars var con (Elaboratable_Apply fc f a) + = pure $ Elaboratable_Apply fc !(updateArg allvars var con f) !(updateArg allvars var con a) -updateArg allvars var con (IWithApp fc f a) - = pure $ IWithApp fc !(updateArg allvars var con f) +updateArg allvars var con (Elaboratable_With_Apply fc f a) + = pure $ Elaboratable_With_Apply fc !(updateArg allvars var con f) !(updateArg allvars var con a) -updateArg allvars var con (IAutoApp fc f a) - = pure $ IAutoApp fc !(updateArg allvars var con f) +updateArg allvars var con (Elaboratable_Automatic_Apply fc f a) + = pure $ Elaboratable_Automatic_Apply fc !(updateArg allvars var con f) !(updateArg allvars var con a) -updateArg allvars var con (INamedApp fc f n a) - = pure $ INamedApp fc !(updateArg allvars var con f) n +updateArg allvars var con (Elaboratable_Named_Apply fc f n a) + = pure $ Elaboratable_Named_Apply fc !(updateArg allvars var con f) n !(updateArg allvars var con a) -updateArg allvars var con (IAs fc nameFC s n p) +updateArg allvars var con (Elaboratable_As_Pattern fc nameFC s n p) = updateArg allvars var con p updateArg allvars var con tm = pure $ Implicit (getFC tm) True @@ -204,37 +204,37 @@ recordUpdate : {auto u : Ref UPD Updates} -> FC -> Name -> RawImp -> Core () recordUpdate fc n tm = do u <- get UPD - let nupdates = mapSnd (IVar fc) <$> namemap u + let nupdates = mapSnd (Elaboratable_Name fc) <$> namemap u put UPD ({ updates $= ((n, substNames [] nupdates tm) ::) } u) findUpdates : {auto u : Ref UPD Updates} -> Defs -> RawImp -> RawImp -> Core () -findUpdates defs (IVar fc n) (IVar _ n') +findUpdates defs (Elaboratable_Name fc n) (Elaboratable_Name _ n') = case !(lookupTyExact n' (gamma defs)) of - Just _ => recordUpdate fc n (IVar fc n') + Just _ => recordUpdate fc n (Elaboratable_Name fc n') Nothing => do u <- get UPD case lookup n' (namemap u) of Nothing => put UPD ({ namemap $= ((n', n) ::) } u) - Just nm => put UPD ({ updates $= ((n, IVar fc nm) ::) } u) -findUpdates defs (IVar fc n) tm = recordUpdate fc n tm -findUpdates defs (IApp _ f a) (IApp _ f' a') + Just nm => put UPD ({ updates $= ((n, Elaboratable_Name fc nm) ::) } u) +findUpdates defs (Elaboratable_Name fc n) tm = recordUpdate fc n tm +findUpdates defs (Elaboratable_Apply _ f a) (Elaboratable_Apply _ f' a') = do findUpdates defs f f' findUpdates defs a a' -findUpdates defs (IAutoApp _ f a) (IAutoApp _ f' a') +findUpdates defs (Elaboratable_Automatic_Apply _ f a) (Elaboratable_Automatic_Apply _ f' a') = do findUpdates defs f f' findUpdates defs a a' -findUpdates defs (IAutoApp _ f a) f' +findUpdates defs (Elaboratable_Automatic_Apply _ f a) f' = findUpdates defs f f' -findUpdates defs f (IAutoApp _ f' a) +findUpdates defs f (Elaboratable_Automatic_Apply _ f' a) = findUpdates defs f f' -findUpdates defs (INamedApp _ f _ a) (INamedApp _ f' _ a') +findUpdates defs (Elaboratable_Named_Apply _ f _ a) (Elaboratable_Named_Apply _ f' _ a') = do findUpdates defs f f' findUpdates defs a a' -findUpdates defs (INamedApp _ f _ a) f' = findUpdates defs f f' -findUpdates defs f (INamedApp _ f' _ a) = findUpdates defs f f' -findUpdates defs (IAs _ _ _ _ f) f' = findUpdates defs f f' -findUpdates defs f (IAs _ _ _ _ f') = findUpdates defs f f' +findUpdates defs (Elaboratable_Named_Apply _ f _ a) f' = findUpdates defs f f' +findUpdates defs f (Elaboratable_Named_Apply _ f' _ a) = findUpdates defs f f' +findUpdates defs (Elaboratable_As_Pattern _ _ _ _ f) f' = findUpdates defs f f' +findUpdates defs f (Elaboratable_As_Pattern _ _ _ _ f') = findUpdates defs f f' findUpdates _ _ _ = pure () getUpdates : Defs -> RawImp -> RawImp -> Core (List (Name, RawImp)) @@ -265,7 +265,7 @@ mkCase {c} {u} fn orig lhs_raw -- once split and turned into a pattern) (lhs, _) <- elabTerm {c} {m} {u} fn (InLHS erased) [] (MkNested []) - Env.empty (IBindHere (getFC lhs_raw) PATTERN lhs_raw) + Env.empty (Elaboratable_Bind_Here (getFC lhs_raw) PATTERN lhs_raw) Nothing -- Revert all public back to false setAllPublic False diff --git a/TTImp/Interactive/ExprSearch.idr b/TTImp/Interactive/ExprSearch.idr index 89e9bd8121..17646ba255 100644 --- a/TTImp/Interactive/ExprSearch.idr +++ b/TTImp/Interactive/ExprSearch.idr @@ -564,7 +564,7 @@ makeHelper fc rig opts env letty targetty ((locapp, ds) :: next) | _ => do log "interaction.search" 10 "No results" noResult - let helperdef = IDef fc helpern (snd helper) + let helperdef = Elaboratable_Definition fc helpern (snd helper) log "interaction.search" 10 $ "Def: " ++ show helperdef pure ((::) (def, helperdef :: ds) -- plus helper (do next' <- next diff --git a/TTImp/Interactive/GenerateDef.idr b/TTImp/Interactive/GenerateDef.idr index e47fb662fc..573cc7b2f2 100644 --- a/TTImp/Interactive/GenerateDef.idr +++ b/TTImp/Interactive/GenerateDef.idr @@ -41,10 +41,10 @@ uniqueRHS (PatClause fc lhs rhs) = pure $ PatClause fc lhs !(mkUniqueName rhs) where mkUniqueName : RawImp -> Core RawImp - mkUniqueName (IHole fc' rhsn) + mkUniqueName (Elaboratable_Hole fc' rhsn) = do defs <- get Ctxt rhsn' <- uniqueHoleName defs [] rhsn - pure (IHole fc' rhsn') + pure (Elaboratable_Hole fc' rhsn') mkUniqueName tm = pure tm -- it'll be a hole, but this is needed for covering uniqueRHS c = pure c @@ -84,21 +84,21 @@ expandClause loc opts n c dropLams : Nat -> RawImp -> RawImp dropLams Z tm = tm - dropLams (S k) (ILam _ _ _ _ _ sc) = dropLams k sc + dropLams (S k) (Elaboratable_Lambda _ _ _ _ _ sc) = dropLams k sc dropLams _ tm = tm splittableNames : RawImp -> List Name -splittableNames (IApp _ f (IBindVar _ n)) +splittableNames (Elaboratable_Apply _ f (Elaboratable_Bind_Name _ n)) = splittableNames f ++ [n] -splittableNames (IApp _ f _) +splittableNames (Elaboratable_Apply _ f _) = splittableNames f -splittableNames (IWithApp _ f (IBindVar _ n)) +splittableNames (Elaboratable_With_Apply _ f (Elaboratable_Bind_Name _ n)) = splittableNames f ++ [n] -splittableNames (IWithApp _ f _) +splittableNames (Elaboratable_With_Apply _ f _) = splittableNames f -splittableNames (IAutoApp _ f _) +splittableNames (Elaboratable_Automatic_Apply _ f _) = splittableNames f -splittableNames (INamedApp _ f _ _) +splittableNames (Elaboratable_Named_Apply _ f _ _) = splittableNames f splittableNames _ = [] @@ -119,26 +119,26 @@ trySplit loc lhsraw lhs rhs n valid _ = Nothing fixNames : RawImp -> RawImp - fixNames (IVar loc' n@(UN (Basic {}))) = IBindVar loc' n - fixNames (IVar loc' (MN {})) = Implicit loc' True - fixNames (IApp loc' f a) = IApp loc' (fixNames f) (fixNames a) - fixNames (IAutoApp loc' f a) = IAutoApp loc' (fixNames f) (fixNames a) - fixNames (INamedApp loc' f t a) = INamedApp loc' (fixNames f) t (fixNames a) + fixNames (Elaboratable_Name loc' n@(UN (Basic {}))) = Elaboratable_Bind_Name loc' n + fixNames (Elaboratable_Name loc' (MN {})) = Implicit loc' True + fixNames (Elaboratable_Apply loc' f a) = Elaboratable_Apply loc' (fixNames f) (fixNames a) + fixNames (Elaboratable_Automatic_Apply loc' f a) = Elaboratable_Automatic_Apply loc' (fixNames f) (fixNames a) + fixNames (Elaboratable_Named_Apply loc' f t a) = Elaboratable_Named_Apply loc' (fixNames f) t (fixNames a) fixNames tm = tm updateLHS : List (Name, RawImp) -> RawImp -> RawImp - updateLHS ups (IVar loc' n) + updateLHS ups (Elaboratable_Name loc' n) = case lookup n ups of - Nothing => IVar loc' n + Nothing => Elaboratable_Name loc' n Just tm => fixNames tm - updateLHS ups (IBindVar loc' n) + updateLHS ups (Elaboratable_Bind_Name loc' n) = case lookup n ups of - Nothing => IBindVar loc' n + Nothing => Elaboratable_Bind_Name loc' n Just tm => fixNames tm - updateLHS ups (IApp loc' f a) = IApp loc' (updateLHS ups f) (updateLHS ups a) - updateLHS ups (IAutoApp loc' f a) = IAutoApp loc' (updateLHS ups f) (updateLHS ups a) - updateLHS ups (INamedApp loc' f t a) - = INamedApp loc' (updateLHS ups f) t (updateLHS ups a) + updateLHS ups (Elaboratable_Apply loc' f a) = Elaboratable_Apply loc' (updateLHS ups f) (updateLHS ups a) + updateLHS ups (Elaboratable_Automatic_Apply loc' f a) = Elaboratable_Automatic_Apply loc' (updateLHS ups f) (updateLHS ups a) + updateLHS ups (Elaboratable_Named_Apply loc' f t a) + = Elaboratable_Named_Apply loc' (updateLHS ups f) t (updateLHS ups a) updateLHS ups tm = tm generateSplits : {auto m : Ref MD Metadata} -> @@ -153,7 +153,7 @@ generateSplits loc opts fn (WithClause fc lhs rig wval prf flags cs) = pure [] generateSplits loc opts fn (PatClause fc lhs rhs) = do (lhstm, _) <- elabTerm fn (InLHS linear) [] (MkNested []) Env.empty - (IBindHere loc PATTERN lhs) Nothing + (Elaboratable_Bind_Here loc PATTERN lhs) Nothing let splitnames = if ltor opts then splittableNames lhs else reverse (splittableNames lhs) @@ -229,8 +229,8 @@ makeDefFromType loc opts n envlen ty rhshole <- uniqueHoleName defs [] (fnName False n ++ "_rhs") let initcs = PatClause loc - (apply (IVar loc n) (pre_env ++ (map (IBindVar loc . UN . Basic) argns))) - (IHole loc rhshole) + (apply (Elaboratable_Name loc n) (pre_env ++ (map (Elaboratable_Bind_Name loc . UN . Basic) argns))) + (Elaboratable_Hole loc rhshole) let Just nidx = getNameID n (gamma defs) | Nothing => undefinedName loc n cs' <- mkSplits loc opts nidx initcs diff --git a/TTImp/Interactive/Intro.idr b/TTImp/Interactive/Intro.idr index 241a782117..9b78c7baac 100644 --- a/TTImp/Interactive/Intro.idr +++ b/TTImp/Interactive/Intro.idr @@ -31,15 +31,15 @@ parameters (hole : Name) (env : Env Term lhsCtxt) - introLam : Name -> RigCount -> Term lhsCtxt -> Core IRawImp + introLam : Name -> RigCount -> Term lhsCtxt -> Core Kinded_Elaboratable_Term introLam x rig ty = do ty <- unelab env ty defs <- get Ctxt new_hole <- uniqueHoleName defs [] (nameRoot hole) - let iintrod = ILam replFC rig Explicit (Just x) ty (IHole replFC new_hole) + let iintrod = Elaboratable_Lambda replFC rig Explicit (Just x) ty (Elaboratable_Hole replFC new_hole) pure iintrod - introCon : Name -> Term lhsCtxt -> Core (List IRawImp) + introCon : Name -> Term lhsCtxt -> Core (List Kinded_Elaboratable_Term) introCon n ty = do defs <- get Ctxt ust <- get UST @@ -71,7 +71,7 @@ parameters pure (catMaybes ics) export - intro : Term lhsCtxt -> Core (List IRawImp) + intro : Term lhsCtxt -> Core (List Kinded_Elaboratable_Term) -- structural cases intro (Bind _ x (Let _ _ ty val) sc) = toList <$> intro (subst val sc) intro (TDelayed _ _ t) = intro t diff --git a/TTImp/Interactive/MakeLemma.idr b/TTImp/Interactive/MakeLemma.idr index f854a59af8..47f562ae29 100644 --- a/TTImp/Interactive/MakeLemma.idr +++ b/TTImp/Interactive/MakeLemma.idr @@ -65,16 +65,16 @@ mkType : FC -> List (Name, Maybe Name, PiInfo RawImp, RigCount, RawImp) -> RawImp -> RawImp mkType loc [] ret = ret mkType loc ((_, n, p, c, ty) :: rest) ret - = IPi loc c p n ty (mkType loc rest ret) + = Elaboratable_Dependent_Function_Type loc c p n ty (mkType loc rest ret) mkApp : FC -> Name -> List (Name, Maybe Name, PiInfo RawImp, RigCount, RawImp) -> RawImp mkApp loc n args - = apply (IVar loc n) (mapMaybe getArg args) + = apply (Elaboratable_Name loc n) (mapMaybe getArg args) where getArg : (Name, Maybe Name, PiInfo RawImp, RigCount, RawImp) -> Maybe RawImp - getArg (x, _, Explicit, _, _) = Just (IVar loc x) + getArg (x, _, Explicit, _, _) = Just (Elaboratable_Name loc x) getArg _ = Nothing -- Return a top level type for the lemma, and an expression which applies diff --git a/TTImp/Parser.idr b/TTImp/Parser.idr index 1606f2da61..02bb95269c 100644 --- a/TTImp/Parser.idr +++ b/TTImp/Parser.idr @@ -36,15 +36,15 @@ atom fname = do start <- location x <- constant end <- location - pure (IPrimVal (MkFC fname start end) x) + pure (Elaboratable_Primitive_Value (MkFC fname start end) x) <|> do start <- location str <- simpleStr end <- location - pure (IPrimVal (MkFC fname start end) (Str str)) + pure (Elaboratable_Primitive_Value (MkFC fname start end) (Str str)) <|> do start <- location exactIdent "Type" end <- location - pure (IType (MkFC fname start end)) + pure (Elaboratable_Type_Universe (MkFC fname start end)) <|> do start <- location symbol "_" end <- location @@ -56,20 +56,20 @@ atom fname <|> do start <- location pragma "search" end <- location - pure (ISearch (MkFC fname start end) 1000) + pure (Elaboratable_Search (MkFC fname start end) 1000) <|> do start <- location x <- name end <- location - pure (IVar (MkFC fname start end) x) + pure (Elaboratable_Name (MkFC fname start end) x) <|> do start <- location symbol "$" x <- userName end <- location - pure (IBindVar (MkFC fname start end) x) + pure (Elaboratable_Bind_Name (MkFC fname start end) x) <|> do start <- location x <- holeName end <- location - pure (IHole (MkFC fname start end) x) + pure (Elaboratable_Hole (MkFC fname start end) x) visOption : Rule Visibility visOption @@ -169,11 +169,11 @@ mutual RawImp applyExpImp start end f [] = f applyExpImp start end f (Left exp :: args) - = applyExpImp start end (IApp (MkFC fname start end) f exp) args + = applyExpImp start end (Elaboratable_Apply (MkFC fname start end) f exp) args applyExpImp start end f (Right (Just n, imp) :: args) - = applyExpImp start end (INamedApp (MkFC fname start end) f n imp) args + = applyExpImp start end (Elaboratable_Named_Apply (MkFC fname start end) f n imp) args applyExpImp start end f (Right (Nothing, imp) :: args) - = applyExpImp start end (IAutoApp (MkFC fname start end) f imp) args + = applyExpImp start end (Elaboratable_Automatic_Apply (MkFC fname start end) f imp) args argExpr : OriginDesc -> IndentInfo -> Rule (Either RawImp (Maybe Name, RawImp)) @@ -197,7 +197,7 @@ mutual pure (Just x, tm)) <|> (do symbol "}" end <- location - pure (Just x, IVar (MkFC fname start end) x)) + pure (Just x, Elaboratable_Name (MkFC fname start end) x)) <|> do symbol "@{" commit tm <- expr fname indents @@ -212,7 +212,7 @@ mutual symbol "@" pat <- simpleExpr fname indents end <- location - pure (IAs (MkFC fname start end) (MkFC fname start nameEnd) UseRight x pat) + pure (Elaboratable_As_Pattern (MkFC fname start end) (MkFC fname start nameEnd) UseRight x pat) simpleExpr : OriginDesc -> IndentInfo -> Rule RawImp simpleExpr fname indents @@ -242,7 +242,7 @@ mutual RawImp -> RawImp pibindAll fc p [] scope = scope pibindAll fc p (ty :: rest) scope - = IPi fc ty.rig p (map val ty.mName) ty.val (pibindAll fc p rest scope) + = Elaboratable_Dependent_Function_Type fc ty.rig p (map val ty.mName) ty.val (pibindAll fc p rest scope) bindList : OriginDesc -> FilePos -> IndentInfo -> Rule (List (RigCount, Name, RawImp)) @@ -350,7 +350,7 @@ mutual bindAll : FC -> List (RigCount, Name, RawImp) -> RawImp -> RawImp bindAll fc [] scope = scope bindAll fc ((rig, n, ty) :: rest) scope - = ILam fc rig Explicit (Just n) ty (bindAll fc rest scope) + = Elaboratable_Lambda fc rig Explicit (Just n) ty (bindAll fc rest scope) let_ : OriginDesc -> IndentInfo -> Rule RawImp let_ fname indents @@ -367,7 +367,7 @@ mutual scope <- typeExpr fname indents end <- location pure (let fc = MkFC fname start end in - ILet fc (boundToFC fname n) rig n.val (Implicit fc False) val scope) + Elaboratable_Binding fc (boundToFC fname n) rig n.val (Implicit fc False) val scope) <|> do start <- location keyword "let" ds <- block (topDecl fname) @@ -375,7 +375,7 @@ mutual keyword "in" scope <- typeExpr fname indents end <- location - pure (ILocal (MkFC fname start end) (collectDefs ds) scope) + pure (Elaboratable_Local_Definitions (MkFC fname start end) (collectDefs ds) scope) case_ : OriginDesc -> IndentInfo -> Rule RawImp case_ fname indents @@ -387,7 +387,7 @@ mutual alts <- block (caseAlt fname) end <- location pure (let fc = MkFC fname start end in - ICase fc opts scr (Implicit fc False) alts) + Elaboratable_Case fc opts scr (Implicit fc False) alts) caseAlt : OriginDesc -> IndentInfo -> Rule ImpClause caseAlt fname indents @@ -419,14 +419,14 @@ mutual symbol "}" sc <- expr fname indents end <- location - pure (IUpdate (MkFC fname start end) (forget fs) sc) + pure (Elaboratable_Record_Update (MkFC fname start end) (forget fs) sc) - field : OriginDesc -> IndentInfo -> Rule IFieldUpdate + field : OriginDesc -> IndentInfo -> Rule Elaboratable_Field_Update field fname indents = do path <- sepBy1 (symbol "->") unqualifiedName - upd <- (do symbol "="; pure ISetField) + upd <- (do symbol "="; pure Elaboratable_Set_Field) <|> - (do symbol "$="; pure ISetFieldApp) + (do symbol "$="; pure Elaboratable_Apply_To_Field) val <- appExpr fname indents pure (upd (forget path) val) @@ -438,7 +438,7 @@ mutual keyword "in" tm <- expr fname indents end <- location - pure (IRewrite (MkFC fname start end) rule tm) + pure (Elaboratable_Rewrite (MkFC fname start end) rule tm) lazy : OriginDesc -> IndentInfo -> Rule RawImp lazy fname indents @@ -446,22 +446,22 @@ mutual exactIdent "Lazy" tm <- simpleExpr fname indents end <- location - pure (IDelayed (MkFC fname start end) LLazy tm) + pure (Elaboratable_Delayed_Type (MkFC fname start end) LLazy tm) <|> do start <- location exactIdent "Inf" tm <- simpleExpr fname indents end <- location - pure (IDelayed (MkFC fname start end) LInf tm) + pure (Elaboratable_Delayed_Type (MkFC fname start end) LInf tm) <|> do start <- location exactIdent "Delay" tm <- simpleExpr fname indents end <- location - pure (IDelay (MkFC fname start end) tm) + pure (Elaboratable_Delay (MkFC fname start end) tm) <|> do start <- location exactIdent "Force" tm <- simpleExpr fname indents end <- location - pure (IForce (MkFC fname start end) tm) + pure (Elaboratable_Force (MkFC fname start end) tm) binder : OriginDesc -> IndentInfo -> Rule RawImp @@ -488,7 +488,7 @@ mutual mkPi : FilePos -> FilePos -> RawImp -> List (PiInfo RawImp, RawImp) -> RawImp mkPi start end arg [] = arg mkPi start end arg ((exp, a) :: as) - = IPi (MkFC fname start end) top exp Nothing arg + = Elaboratable_Dependent_Function_Type (MkFC fname start end) top exp Nothing arg (mkPi start end a as) export @@ -541,10 +541,10 @@ mutual pure (!(getFn lhs), ImpossibleClause fc lhs) where getFn : RawImp -> EmptyRule Name - getFn (IVar _ n) = pure n - getFn (IApp _ f a) = getFn f - getFn (IAutoApp _ f a) = getFn f - getFn (INamedApp _ f _ a) = getFn f + getFn (Elaboratable_Name _ n) = pure n + getFn (Elaboratable_Apply _ f a) = getFn f + getFn (Elaboratable_Automatic_Apply _ f a) = getFn f + getFn (Elaboratable_Named_Apply _ f _ a) = getFn f getFn _ = fail "Not a function application" clause : Nat -> OriginDesc -> IndentInfo -> Rule (Name, ImpClause) @@ -558,7 +558,7 @@ mutual where applyArgs : RawImp -> List (FC, RawImp) -> RawImp applyArgs f [] = f - applyArgs f ((fc, a) :: args) = applyArgs (IApp fc f a) args + applyArgs f ((fc, a) :: args) = applyArgs (Elaboratable_Apply fc f a) args parseWithArg : Rule (FC, RawImp) parseWithArg @@ -573,7 +573,7 @@ definition fname indents = do start <- location nd <- clause 0 fname indents end <- location - pure (IDef (MkFC fname start end) (fst nd) [snd nd]) + pure (Elaboratable_Definition (MkFC fname start end) (fst nd) [snd nd]) dataOpt : Rule DataOpt dataOpt @@ -627,7 +627,7 @@ recordParam fname indents <|> do n <- withFC name pure [ Mk [top, n] (MkPiBindData Explicit (Implicit n.fc False)) ] -fieldDecl : OriginDesc -> IndentInfo -> Rule (List IField) +fieldDecl : OriginDesc -> IndentInfo -> Rule (List Elaboratable_Field) fieldDecl fname indents = do symbol "{" commit @@ -639,7 +639,7 @@ fieldDecl fname indents atEnd indents pure fs where - fieldBody : PiInfo RawImp -> Rule (List IField) + fieldBody : PiInfo RawImp -> Rule (List Elaboratable_Field) fieldBody p = do start <- location ns <- sepBy1 (symbol ",") (withFC userName) @@ -666,7 +666,7 @@ recordDecl fname indents flds <- assert_total (blockAfter col (fieldDecl fname)) end <- location pure (let fc = MkFC fname start end - in IRecord fc Nothing vis mbtot + in Elaboratable_Record_Declaration fc Nothing vis mbtot (Mk [fc] $ MkImpRecord (Mk [n] params) (Mk [dc, opts] (concat flds)))) namespaceDecl : Rule Namespace @@ -688,16 +688,16 @@ directive fname indents commit lvl <- logLevel atEnd indents - pure (ILog lvl) + pure (Elaboratable_Logging lvl) <|> do b <- bounds (do pragma "builtin" commit t <- builtinType n <- name pure (t, n)) (t, n) <- pure b.val - pure $ IBuiltin (boundToFC fname b) t n + pure $ Elaboratable_Builtin_Declaration (boundToFC fname b) t n - {- Can't do IPragma due to lack of Ref Ctxt. Should we worry about this? + {- Can't do Elaboratable_Pragma due to lack of Ref Ctxt. Should we worry about this? <|> do pragma "pair" commit start <- location @@ -706,7 +706,7 @@ directive fname indents s <- name end <- location pure (let fc = MkFC fname start end in - IPragma (\nest, env => setPair {c} fc p f s)) + Elaboratable_Pragma (\nest, env => setPair {c} fc p f s)) <|> do pragma "rewrite" commit start <- location @@ -714,7 +714,7 @@ directive fname indents rw <- name end <- location pure (let fc = MkFC fname start end in - IPragma (\c, nest, env => setRewrite {c} fc eq rw)) + Elaboratable_Pragma (\c, nest, env => setRewrite {c} fc eq rw)) -} -- Declared at the top -- topDecl : OriginDesc -> IndentInfo -> Rule ImpDecl @@ -723,12 +723,12 @@ topDecl fname indents (vis,mbtot) <- dataVisOpt dat <- dataDecl fname indents end <- location - pure (IData (MkFC fname start end) vis mbtot dat) + pure (Elaboratable_Data_Declaration (MkFC fname start end) vis mbtot dat) <|> do start <- location ns <- namespaceDecl ds <- assert_total (nonEmptyBlock (topDecl fname)) end <- location - pure (INamespace (MkFC fname start end) ns (forget ds)) + pure (Elaboratable_Namespace_Block (MkFC fname start end) ns (forget ds)) <|> do start <- location visOpts <- many visOpt vis <- getVisibility Nothing visOpts @@ -737,7 +737,7 @@ topDecl fname indents rig <- getMult m claim <- tyDecl fname indents end <- location - pure (IClaim (MkFCVal (MkFC fname start end) $ MkIClaimData rig vis opts claim)) + pure (Elaboratable_Claim (MkFCVal (MkFC fname start end) $ Make_Elaboratable_Claim_Data rig vis opts claim)) <|> recordDecl fname indents <|> directive fname indents <|> definition fname indents @@ -745,9 +745,9 @@ topDecl fname indents -- Declared at the top -- collectDefs : List ImpDecl -> List ImpDecl collectDefs [] = [] -collectDefs (IDef loc fn cs :: ds) +collectDefs (Elaboratable_Definition loc fn cs :: ds) = let (cs', rest) = spanMap (isClause fn) ds in - IDef loc fn (cs ++ cs') :: assert_total (collectDefs rest) + Elaboratable_Definition loc fn (cs ++ cs') :: assert_total (collectDefs rest) where spanMap : (a -> Maybe (List b)) -> List a -> (List b, List a) spanMap f [] = ([], []) @@ -757,13 +757,13 @@ collectDefs (IDef loc fn cs :: ds) (ys, zs) => (y ++ ys, zs) isClause : Name -> ImpDecl -> Maybe (List ImpClause) - isClause n (IDef _ n' cs) + isClause n (Elaboratable_Definition _ n' cs) = if n == n' then Just cs else Nothing isClause n _ = Nothing -collectDefs (INamespace loc ns nds :: ds) - = INamespace loc ns (collectDefs nds) :: collectDefs ds -collectDefs (IFail loc msg nds :: ds) - = IFail loc msg (collectDefs nds) :: collectDefs ds +collectDefs (Elaboratable_Namespace_Block loc ns nds :: ds) + = Elaboratable_Namespace_Block loc ns (collectDefs nds) :: collectDefs ds +collectDefs (Elaboratable_Expected_Failure loc msg nds :: ds) + = Elaboratable_Expected_Failure loc msg (collectDefs nds) :: collectDefs ds collectDefs (d :: ds) = d :: collectDefs ds diff --git a/TTImp/PartialEval.idr b/TTImp/PartialEval.idr index 1b1940f7a0..b49adea377 100644 --- a/TTImp/PartialEval.idr +++ b/TTImp/PartialEval.idr @@ -135,8 +135,8 @@ getSpecPats fc pename fn stk fnty args sargs pats -- on the lhs, and using the specialised function application on the rhs. -- Then, this will get evaluated on elaboration. dynnames <- mkDynNames args - let lhs = apply (IVar fc pename) (map (IBindVar fc) dynnames) - rhs <- mkRHSargs fnty (IVar fc fn) dynnames args + let lhs = apply (Elaboratable_Name fc pename) (map (Elaboratable_Bind_Name fc) dynnames) + rhs <- mkRHSargs fnty (Elaboratable_Name fc fn) dynnames args pure (Just [PatClause fc lhs rhs]) where mkDynNames : List (Nat, ArgMode) -> Core (List Name) @@ -152,51 +152,51 @@ getSpecPats fc pename fn stk fnty args sargs pats mkRHSargs (NBind _ x (Pi _ _ Explicit _) sc) app (a :: as) ((_, Dynamic) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) - mkRHSargs sc' (IApp fc app (IVar fc a)) as ds + mkRHSargs sc' (Elaboratable_Apply fc app (Elaboratable_Name fc a)) as ds mkRHSargs (NBind _ x (Pi {}) sc) app (a :: as) ((_, Dynamic) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) - mkRHSargs sc' (INamedApp fc app x (IVar fc a)) as ds + mkRHSargs sc' (Elaboratable_Named_Apply fc app x (Elaboratable_Name fc a)) as ds mkRHSargs (NBind _ x (Pi _ _ Explicit _) sc) app as ((_, Static tm) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) tm' <- unelabNoSugar Env.empty tm - mkRHSargs sc' (IApp fc app (map rawName tm')) as ds + mkRHSargs sc' (Elaboratable_Apply fc app (map rawName tm')) as ds mkRHSargs (NBind _ x (Pi _ _ Implicit _) sc) app as ((_, Static tm) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) tm' <- unelabNoSugar Env.empty tm - mkRHSargs sc' (INamedApp fc app x (map rawName tm')) as ds + mkRHSargs sc' (Elaboratable_Named_Apply fc app x (map rawName tm')) as ds mkRHSargs (NBind _ _ (Pi _ _ AutoImplicit _) sc) app as ((_, Static tm) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) tm' <- unelabNoSugar Env.empty tm - mkRHSargs sc' (IAutoApp fc app (map rawName tm')) as ds + mkRHSargs sc' (Elaboratable_Automatic_Apply fc app (map rawName tm')) as ds -- Type will depend on the value here (we assume a variadic function) but -- the argument names are still needed mkRHSargs ty app (a :: as) ((_, Dynamic) :: ds) - = mkRHSargs ty (IApp fc app (IVar fc a)) as ds + = mkRHSargs ty (Elaboratable_Apply fc app (Elaboratable_Name fc a)) as ds mkRHSargs _ app _ _ = pure app getRawArgs : List (Arg' Name) -> RawImp -> List (Arg' Name) - getRawArgs args (IApp fc f arg) = getRawArgs (Explicit fc arg :: args) f - getRawArgs args (INamedApp fc f n arg) + getRawArgs args (Elaboratable_Apply fc f arg) = getRawArgs (Explicit fc arg :: args) f + getRawArgs args (Elaboratable_Named_Apply fc f n arg) = getRawArgs (Named fc n arg :: args) f - getRawArgs args (IAutoApp fc f arg) + getRawArgs args (Elaboratable_Automatic_Apply fc f arg) = getRawArgs (Auto fc arg :: args) f getRawArgs args tm = args reapply : RawImp -> List (Arg' Name) -> RawImp reapply f [] = f - reapply f (Explicit fc arg :: args) = reapply (IApp fc f arg) args + reapply f (Explicit fc arg :: args) = reapply (Elaboratable_Apply fc f arg) args reapply f (Named fc n arg :: args) - = reapply (INamedApp fc f n arg) args + = reapply (Elaboratable_Named_Apply fc f n arg) args reapply f (Auto fc arg :: args) - = reapply (IAutoApp fc f arg) args + = reapply (Elaboratable_Automatic_Apply fc f arg) args dropArgs : Name -> RawImp -> RawImp - dropArgs pename tm = reapply (IVar fc pename) (dropSpec 0 sargs (getRawArgs [] tm)) + dropArgs pename tm = reapply (Elaboratable_Name fc pename) (dropSpec 0 sargs (getRawArgs [] tm)) unelabPat : Name -> (vs ** (Env Term vs, Term vs, Term vs)) -> Core ImpClause @@ -209,7 +209,7 @@ getSpecPats fc pename fn stk fnty args sargs pats rhs <- normaliseArgHoles defs env rhs rhs <- unelabNoSugar env rhs let rhs = flip mapTTImp rhs $ \case - IHole fc _ => Implicit fc False + Elaboratable_Hole fc _ => Implicit fc False tm => tm pure (PatClause fc lhs' (map rawName rhs)) @@ -306,7 +306,7 @@ mkSpecDef {vars} fc gdef pename sargs fn stk log "specialise" 5 $ "New patterns for " ++ show pename ++ ":\n" ++ showSep "\n" (map showPat newpats) processDecl [InPartialEval] (MkNested []) Env.empty - (IDef fc (Resolved peidx) newpats) + (Elaboratable_Definition fc (Resolved peidx) newpats) setAllPublic False pure peapp) -- If the partially evaluated definition fails, just use the initial @@ -342,10 +342,10 @@ mkSpecDef {vars} fc gdef pename sargs fn stk getAllRefs ns [] = ns updateApp : Name -> RawImp -> RawImp - updateApp n (IApp fc f a) = IApp fc (updateApp n f) a - updateApp n (IAutoApp fc f a) = IAutoApp fc (updateApp n f) a - updateApp n (INamedApp fc f m a) = INamedApp fc (updateApp n f) m a - updateApp n f = IVar fc n + updateApp n (Elaboratable_Apply fc f a) = Elaboratable_Apply fc (updateApp n f) a + updateApp n (Elaboratable_Automatic_Apply fc f a) = Elaboratable_Automatic_Apply fc (updateApp n f) a + updateApp n (Elaboratable_Named_Apply fc f m a) = Elaboratable_Named_Apply fc (updateApp n f) m a + updateApp n f = Elaboratable_Name fc n unelabDef : (vs ** (Env Term vs, Term vs, Term vs)) -> Core ImpClause diff --git a/TTImp/ProcessData.idr b/TTImp/ProcessData.idr index 43c9a9ab63..8d8d800c7c 100644 --- a/TTImp/ProcessData.idr +++ b/TTImp/ProcessData.idr @@ -66,17 +66,17 @@ checkFamily loc cn tn env nf _ => throw $ BadDataConType loc cn tn updateNS : Name -> Name -> RawImp -> RawImp -updateNS orig ns (IPi fc c p n ty sc) = IPi fc c p n ty (updateNS orig ns sc) +updateNS orig ns (Elaboratable_Dependent_Function_Type fc c p n ty sc) = Elaboratable_Dependent_Function_Type fc c p n ty (updateNS orig ns sc) updateNS orig ns tm = updateNSApp tm where updateNSApp : RawImp -> RawImp - updateNSApp (IVar fc n) -- data type type, must be defined in this namespace + updateNSApp (Elaboratable_Name fc n) -- data type type, must be defined in this namespace = if n == orig - then IVar fc ns - else IVar fc n - updateNSApp (IApp fc f arg) = IApp fc (updateNSApp f) arg - updateNSApp (IAutoApp fc f arg) = IAutoApp fc (updateNSApp f) arg - updateNSApp (INamedApp fc f n arg) = INamedApp fc (updateNSApp f) n arg + then Elaboratable_Name fc ns + else Elaboratable_Name fc n + updateNSApp (Elaboratable_Apply fc f arg) = Elaboratable_Apply fc (updateNSApp f) arg + updateNSApp (Elaboratable_Automatic_Apply fc f arg) = Elaboratable_Automatic_Apply fc (updateNSApp f) arg + updateNSApp (Elaboratable_Named_Apply fc f n arg) = Elaboratable_Named_Apply fc (updateNSApp f) n arg updateNSApp t = t checkCon : {vars : _} -> @@ -104,7 +104,7 @@ checkCon {vars} opts nest env vis tn_in tn ty_raw ty <- wrapErrorC opts (InCon cn_in) $ checkTerm !(resolveName cn) InType opts nest env - (IBindHere fc (PI erased) ty_raw) + (Elaboratable_Bind_Here fc (PI erased) ty_raw) (gType fc u) -- Check 'ty' returns something in the right family @@ -414,7 +414,7 @@ processData {vars} eopts nest env fc def_vis mbtot (MkImpLater dfc n_in ty_raw) (ty, _) <- wrapErrorC eopts (InCon $ MkFCVal dfc n) $ elabTerm !(resolveName n) InType eopts nest env - (IBindHere fc (PI erased) ty_raw) + (Elaboratable_Bind_Here fc (PI erased) ty_raw) (Just (gType dfc u)) let fullty = abstractEnvType dfc env ty logTermNF "declare.data" 5 ("data " ++ show n) Env.empty fullty @@ -456,7 +456,7 @@ processData {vars} eopts nest env fc def_vis mbtot (MkImpData dfc n_in mty_raw o (ty, _) <- wrapErrorC eopts (InCon $ MkFCVal fc n) $ elabTerm !(resolveName n) InType eopts nest env - (IBindHere fc (PI erased) ty_raw) + (Elaboratable_Bind_Here fc (PI erased) ty_raw) (Just (gType dfc u)) checkIsType fc n env !(nf defs env ty) diff --git a/TTImp/ProcessDecls.idr b/TTImp/ProcessDecls.idr index c79bbf429d..58eedbe83a 100644 --- a/TTImp/ProcessDecls.idr +++ b/TTImp/ProcessDecls.idr @@ -110,30 +110,30 @@ process : {vars : _} -> {auto o : Ref ROpts REPLOpts} -> List ElabOpt -> NestedNames vars -> Env Term vars -> ImpDecl -> Core () -process eopts nest env (IClaim dat@(MkWithData fc (MkIClaimData rig vis opts ty))) +process eopts nest env (Elaboratable_Claim dat@(MkWithData fc (Make_Elaboratable_Claim_Data rig vis opts ty))) = processType eopts nest env dat.fc rig vis opts ty -process eopts nest env (IData fc vis mbtot ddef) +process eopts nest env (Elaboratable_Data_Declaration fc vis mbtot ddef) = processData eopts nest env fc vis mbtot ddef -process eopts nest env (IDef fc fname def) +process eopts nest env (Elaboratable_Definition fc fname def) = processDef eopts nest env fc fname def -process eopts nest env (IParameters fc ps decls) +process eopts nest env (Elaboratable_Parameter_Block fc ps decls) = processParams nest env fc (forget ps) decls -process eopts nest env (IRecord fc ns vis mbtot rec) +process eopts nest env (Elaboratable_Record_Declaration fc ns vis mbtot rec) = processRecord eopts nest env ns vis mbtot rec -process eopts nest env (IFail fc msg decls) +process eopts nest env (Elaboratable_Expected_Failure fc msg decls) = processFailing eopts nest env fc msg decls -process eopts nest env (INamespace fc ns decls) +process eopts nest env (Elaboratable_Namespace_Block fc ns decls) = withExtendedNS ns $ traverse_ (processDecl eopts nest env) decls -process eopts nest env (ITransform fc n lhs rhs) +process eopts nest env (Elaboratable_Transformation fc n lhs rhs) = processTransform eopts nest env fc n lhs rhs -process eopts nest env (IRunElabDecl fc tm) +process eopts nest env (Elaboratable_Run_Elaborator_Declaration fc tm) = processRunElab eopts nest env fc tm -process eopts nest env (IPragma _ _ act) +process eopts nest env (Elaboratable_Pragma _ _ act) = act nest env -process eopts nest env (ILog lvl) +process eopts nest env (Elaboratable_Logging lvl) = addLogLevel (uncurry unsafeMkLogLevel <$> lvl) -process eopts nest env (IBuiltin fc type name) +process eopts nest env (Elaboratable_Builtin_Declaration fc type name) = processBuiltin nest env fc type name TTImp.Elab.Check.processDecl = process @@ -177,12 +177,12 @@ processTTImpDecls {vars} nest env decls -- bind implicits to make raw TTImp source a bit friendlier bindNames : ImpDecl -> Core ImpDecl - bindNames (IClaim dat@(MkWithData fc (MkIClaimData c vis opts ty))) + bindNames (Elaboratable_Claim dat@(MkWithData fc (Make_Elaboratable_Claim_Data c vis opts ty))) = do ty' <- bindTypeNames dat.fc [] (toList vars) ty.val - pure (IClaim (MkWithData fc (MkIClaimData c vis opts ({val := ty'} ty)))) - bindNames (IData fc vis mbtot d) + pure (Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data c vis opts ({val := ty'} ty)))) + bindNames (Elaboratable_Data_Declaration fc vis mbtot d) = do d' <- bindDataNames d - pure (IData fc vis mbtot d') + pure (Elaboratable_Data_Declaration fc vis mbtot d') bindNames d = pure d export diff --git a/TTImp/ProcessDef.idr b/TTImp/ProcessDef.idr index b74e392098..2f52605af1 100644 --- a/TTImp/ProcessDef.idr +++ b/TTImp/ProcessDef.idr @@ -322,7 +322,7 @@ checkLHS {vars} trans mult n opts nest env fc lhs_in (lhstm, lhstyg) <- wrapErrorC opts (InLHS fc !(getFullName (Resolved n))) $ elabTerm n lhsMode opts nest env - (IBindHere fc PATTERN lhs) Nothing + (Elaboratable_Bind_Here fc PATTERN lhs) Nothing logTerm "declare.def.lhs" 5 "Checked LHS term" lhstm lhsty <- getTerm lhstyg @@ -399,7 +399,7 @@ checkClause mult vis totreq hashit n opts nest env (ImpossibleClause fc lhs) logEnv "declare.def.clause.impossible" 5 "In env" env (lhstm, lhstyg) <- elabTerm n (InLHS mult) opts nest env - (IBindHere fc COVERAGE lhs) Nothing + (Elaboratable_Bind_Here fc COVERAGE lhs) Nothing defs <- get Ctxt lhs <- normaliseHoles defs env lhstm if !(hasEmptyPat defs env lhs) @@ -513,17 +513,17 @@ checkClause {vars} mult vis totreq hashit n opts nest env vars wtype (specified vis) None)) let toWarg : Maybe (PiInfo RawImp, Name) -> List (Maybe Name, RawImp) - := flip maybe (\pn => [(Nothing, IVar vfc (snd pn))]) $ + := flip maybe (\pn => [(Nothing, Elaboratable_Name vfc (snd pn))]) $ (Nothing, wval_raw) :: case mprf of Nothing => [] Just _ => let fc = emptyFC in - let refl = IVar fc (NS builtinNS (UN $ Basic "Refl")) in - [(map snd mprf, INamedApp fc refl (UN $ Basic "x") wval_raw)] + let refl = Elaboratable_Name fc (NS builtinNS (UN $ Basic "Refl")) in + [(map snd mprf, Elaboratable_Named_Apply fc refl (UN $ Basic "x") wval_raw)] - let rhs_in = gapply (IVar vfc wname) - $ map (\ nm => (Nothing, IVar vfc nm)) envns + let rhs_in = gapply (Elaboratable_Name vfc wname) + $ map (\ nm => (Nothing, Elaboratable_Name vfc nm)) envns ++ concatMap toWarg wargNames log "declare.def.clause.with" 3 $ "Applying to with argument " ++ show rhs_in @@ -539,7 +539,7 @@ checkClause {vars} mult vis totreq hashit n opts nest env nestname <- applyEnv env wname let nest'' = { names $= (nestname ::) } nest - let wdef = IDef ifc wname cs' + let wdef = Elaboratable_Definition ifc wname cs' processDecl [] nest'' env wdef pure (Right (MkClause env' lhspat rhs)) @@ -819,8 +819,8 @@ isAlias : RawImp -> Maybe ((FC, Name) -- head symbol , List (FC, (FC, Name))) -- pattern variables isAlias lhs = do let (hd, apps) = getFnArgs lhs [] - hd <- isIVar hd - args <- traverse (isExplicit >=> bitraverse pure isIBindVar) apps + hd <- is_elaboratable_name hd + args <- traverse (isExplicit >=> bitraverse pure is_elaboratable_bound_name) apps pure (hd, args) lookupOrAddAlias : {vars : _} -> @@ -870,7 +870,7 @@ lookupOrAddAlias eopts nest env fc n [cl@(PatClause _ lhs _)] holeyType [] = Implicit fc False holeyType ((xfc, x) :: xs) = let xfc = virtualiseFC xfc in - IPi xfc top Explicit (Just x) (Implicit xfc False) + Elaboratable_Dependent_Function_Type xfc top Explicit (Just x) (Implicit xfc False) $ holeyType xs lookupOrAddAlias _ _ _ fc n _ @@ -1009,7 +1009,7 @@ processDef opts nest env fc n_in cs_in (_, lhstm) <- bindNames False itm setUnboundImplicits autoimp (lhstm, _) <- elabTerm n (InLHS mult) [] (MkNested []) Env.empty - (IBindHere fc COVERAGE lhstm) Nothing + (Elaboratable_Bind_Here fc COVERAGE lhstm) Nothing defs <- get Ctxt lhs <- normaliseHoles defs Env.empty lhstm if !(hasEmptyPat defs Env.empty lhs) diff --git a/TTImp/ProcessParams.idr b/TTImp/ProcessParams.idr index 35ca12f8b5..f80d082b49 100644 --- a/TTImp/ProcessParams.idr +++ b/TTImp/ProcessParams.idr @@ -39,7 +39,7 @@ processParams {vars} {c} {m} {u} nest env fc ps ds -- then read off the environment from the elaborated type. This way -- we'll get all the implicit names we need let pty_raw = mkParamTy ps - pty_imp <- bindTypeNames fc [] (toList vars) (IBindHere fc (PI erased) pty_raw) + pty_imp <- bindTypeNames fc [] (toList vars) (Elaboratable_Bind_Here fc (PI erased) pty_raw) log "declare.param" 10 $ "Checking " ++ show pty_imp u <- uniVar fc pty <- checkTerm (-1) InType [] @@ -56,9 +56,9 @@ processParams {vars} {c} {m} {u} nest env fc ps ds traverse_ (processDecl [] nestBlock env') ds where mkParamTy : List ImpParameter -> RawImp - mkParamTy [] = IType fc + mkParamTy [] = Elaboratable_Type_Universe fc mkParamTy (binder :: ps) - = IPi fc binder.rig binder.val.info (Just binder.name.val) binder.val.boundType (mkParamTy ps) + = Elaboratable_Dependent_Function_Type fc binder.rig binder.val.info (Just binder.name.val) binder.val.boundType (mkParamTy ps) applyEnv : {vs : _} -> Env Term vs -> Name -> diff --git a/TTImp/ProcessRecord.idr b/TTImp/ProcessRecord.idr index 7f1712befd..314ad2158d 100644 --- a/TTImp/ProcessRecord.idr +++ b/TTImp/ProcessRecord.idr @@ -25,7 +25,7 @@ import Data.String -- errors because they've been duplicated when forming the various types of the -- record constructor, getters, etc. killHole : RawImp -> RawImp -killHole (IHole fc str) = Implicit fc True +killHole (Elaboratable_Hole fc str) = Implicit fc True killHole t = t -- Projections are only visible if the record is public export @@ -47,7 +47,7 @@ elabRecord : {vars : _} -> (params : List ImpParameter) -> (opts : List DataOpt) -> (conName : Name) -> - List IField -> + List Elaboratable_Field -> Core () elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conName_in fields = do tn <- inCurrentNS tn_in @@ -94,34 +94,34 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa -- and projections jname binder = Mk [EmptyFC, erased, Just binder.name] $ {info := Implicit} binder.val - fname : IField -> Name + fname : Elaboratable_Field -> Name fname field = field.name.val - farg : IField -> AddFC (WithRig $ WithMName (PiBindData RawImp)) + farg : Elaboratable_Field -> AddFC (WithRig $ WithMName (PiBindData RawImp)) farg field = Mk [virtualiseFC field.fc, field.rig, Just field.name] field.val mkTy : List (AddFC $ WithRig $ WithMName (PiBindData RawImp)) -> RawImp -> RawImp mkTy [] ret = ret mkTy (bind :: args) ret - = IPi bind.fc bind.rig bind.val.info (map val bind.mName) bind.val.boundType (mkTy args ret) + = Elaboratable_Dependent_Function_Type bind.fc bind.rig bind.val.info (map val bind.mName) bind.val.boundType (mkTy args ret) recTy : (tn : Name) -> -- fully qualified name of the record type (params : List ImpParameter) -> -- list of all the parameters RawImp - recTy tn params = apply (IVar (virtualiseFC fc) tn) (map (\binder => (binder.name.val, IVar EmptyFC binder.name.val, binder.val.info)) params) + recTy tn params = apply (Elaboratable_Name (virtualiseFC fc) tn) (map (\binder => (binder.name.val, Elaboratable_Name EmptyFC binder.name.val, binder.val.info)) params) where ||| Apply argument to list of explicit or implicit named arguments apply : RawImp -> List (Name, RawImp, PiInfo RawImp) -> RawImp apply f [] = f - apply f ((n, arg, Explicit) :: xs) = apply (IApp (getFC f) f arg) xs - apply f ((n, arg, _ ) :: xs) = apply (INamedApp (getFC f) f n arg) xs + apply f ((n, arg, Explicit) :: xs) = apply (Elaboratable_Apply (getFC f) f arg) xs + apply f ((n, arg, _ ) :: xs) = apply (Elaboratable_Named_Apply (getFC f) f n arg) xs paramNames : List ImpParameter -> List Name paramNames params = map (.name.val) params mkDataTy : FC -> List ImpParameter -> RawImp - mkDataTy fc [] = IType fc - mkDataTy fc (binder :: ps) = IPi fc binder.rig binder.val.info (Just binder.name.val) binder.val.boundType (mkDataTy fc ps) + mkDataTy fc [] = Elaboratable_Type_Universe fc + mkDataTy fc (binder :: ps) = Elaboratable_Dependent_Function_Type fc binder.rig binder.val.info (Just binder.name.val) binder.val.boundType (mkDataTy fc ps) nestDrop : Core (List (Name, Nat)) nestDrop @@ -139,13 +139,13 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa Core (List ImpParameter) -- New telescope of parameters, including missing bindings preElabAsData tn = do let fc = virtualiseFC fc - let dataTy = IBindHere fc (PI erased) !(bindTypeNames fc [] (toList vars) (mkDataTy fc params0)) + let dataTy = Elaboratable_Bind_Here fc (PI erased) !(bindTypeNames fc [] (toList vars) (mkDataTy fc params0)) defs <- get Ctxt -- Create a forward declaration if none exists when (isNothing !(lookupTyExact tn (gamma defs))) $ do let dt = MkImpLater fc tn dataTy log "declare.record" 10 $ "Pre-declare record data type: \{show dt}" - processDecl [] nest env (IData fc def_vis mbtot dt) + processDecl [] nest env (Elaboratable_Data_Declaration fc def_vis mbtot dt) defs <- get Ctxt Just ty <- lookupTyExact tn (gamma defs) | Nothing => throw (InternalError "Missing data type \{show tn}, despite having just declared it!") @@ -180,10 +180,10 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa SnocList (WithRig $ WithMName $ PiBindData RawImp) -> -- accumulator RawImp' KindedName -> -- quoted type (some names may have disappeared) Core (SnocList (WithRig $ WithMName $ PiBindData RawImp)) - getParameters acc (IPi fc rig pinfo mnm argTy retTy) + getParameters acc (Elaboratable_Dependent_Function_Type fc rig pinfo mnm argTy retTy) = let clean = mapTTImp killHole . map fullName in getParameters (acc :< (Mk [rig, map NoFC mnm] (MkPiBindData (map clean pinfo) (clean argTy)))) retTy - getParameters acc (IType _) = pure acc + getParameters acc (Elaboratable_Type_Universe _) = pure acc getParameters acc ty = throw (InternalError "Malformed record type \{show ty}") addMissingNames : @@ -221,7 +221,7 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa !(bindTypeNames fc [] boundNames conty) let dt = MkImpData fc tn Nothing opts [con] log "declare.record" 5 $ "Record data type " ++ show dt - processDecl [] nest env (IData fc def_vis mbtot dt) + processDecl [] nest env (Elaboratable_Data_Declaration fc def_vis mbtot dt) countExp : Term vs -> Nat countExp (Bind _ _ (Pi _ _ Explicit _) sc) = S (countExp sc) @@ -267,11 +267,11 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa projTy <- bindTypeNames fc [] (paramNames ++ map fname fields ++ toList vars) $ mkTy (paramTelescope params) $ - IPi bfc top Explicit (Just rname) (recTy tn params) ty' + Elaboratable_Dependent_Function_Type bfc top Explicit (Just rname) (recTy tn params) ty' let fc' = virtualiseFC fc let mkProjClaim = \ nm => let ty = Mk [fc', MkFCVal fc' nm] projTy - in IClaim (MkFCVal bfc (MkIClaimData rig isVis [Inline] ty)) + in Elaboratable_Claim (MkFCVal bfc (Make_Elaboratable_Claim_Data rig isVis [Inline] ty)) log "declare.record.projection.claim" 5 $ "Projection " ++ show rfNameNS ++ ": " ++ show projTy @@ -279,18 +279,18 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa -- Define the LHS and RHS let lhs_exp - = apply (IVar bfc con) + = apply (Elaboratable_Name bfc con) (replicate done (Implicit bfc True) ++ (if imp == Explicit - then [IBindVar fc' unName] + then [Elaboratable_Bind_Name fc' unName] else []) ++ (replicate (countExp sc) (Implicit bfc True))) - let lhs = IApp bfc (IVar bfc rfNameNS) + let lhs = Elaboratable_Apply bfc (Elaboratable_Name bfc rfNameNS) (if imp == Explicit then lhs_exp - else INamedApp bfc lhs_exp unName - (IBindVar bfc unName)) - let rhs = IVar fc' unName + else Elaboratable_Named_Apply bfc lhs_exp unName + (Elaboratable_Bind_Name bfc unName)) + let rhs = Elaboratable_Name fc' unName -- EtaExpand implicits on both sides: -- First, obtain all the implicit names in the prefix of @@ -299,7 +299,7 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa log "declare.record.projection.clause" 5 $ "Projection " ++ show lhs ++ " = " ++ show rhs processDecl [] nest env - (IDef bfc rfNameNS [PatClause bfc lhs rhs]) + (Elaboratable_Definition bfc rfNameNS [PatClause bfc lhs rhs]) -- Make prefix projection aliases if requested when !isPrefixRecordProjections $ do -- beware: `!` is NOT boolean `not`! @@ -310,12 +310,12 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa processDecl [] nest env (mkProjClaim unNameNS) -- Define the LHS and RHS - let lhs = IVar bfc unNameNS - let rhs = IVar bfc rfNameNS + let lhs = Elaboratable_Name bfc unNameNS + let rhs = Elaboratable_Name bfc rfNameNS log "declare.record.projection.prefix" 5 $ "Prefix projection " ++ show lhs ++ " = " ++ show rhs processDecl [] nest env - (IDef bfc unNameNS [PatClause bfc lhs rhs]) + (Elaboratable_Definition bfc unNameNS [PatClause bfc lhs rhs]) -- Move on to the next getter. -- @@ -328,8 +328,8 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa -- (though the only difference I'm aware is in the output of the `:doc` command) prefix_flag <- isPrefixRecordProjections let upds' = if prefix_flag - then (n, IApp bfc (IVar bfc unNameNS) (IVar bfc rname)) :: upds - else (n, IApp bfc (IVar bfc rfNameNS) (IVar bfc rname)) :: upds + then (n, Elaboratable_Apply bfc (Elaboratable_Name bfc unNameNS) (Elaboratable_Name bfc rname)) :: upds + else (n, Elaboratable_Apply bfc (Elaboratable_Name bfc rfNameNS) (Elaboratable_Name bfc rname)) :: upds elabGetters tn con params (if imp == Explicit diff --git a/TTImp/ProcessType.idr b/TTImp/ProcessType.idr index 85448d5e21..b1b813c67f 100644 --- a/TTImp/ProcessType.idr +++ b/TTImp/ProcessType.idr @@ -29,7 +29,7 @@ getFnString : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> {auto o : Ref ROpts REPLOpts} -> RawImp -> Core String -getFnString (IPrimVal _ (Str st)) = pure st +getFnString (Elaboratable_Primitive_Value _ (Str st)) = pure st getFnString tm = do inidx <- resolveName (UN $ Basic "[foreign]") let fc = getFC tm @@ -120,7 +120,7 @@ findInferrable defs ty = fi 0 0 [] NatSet.empty ty fi pos i args acc ret = findInf acc args ret checkForShadowing : (env : StringMap FC) -> RawImp -> StringMap (FC, FC) -checkForShadowing env (IPi fc _ _ nm argTy retTy) +checkForShadowing env (Elaboratable_Dependent_Function_Type fc _ _ nm argTy retTy) = do let argShadowing = checkForShadowing empty argTy let retShadowing = case nm of @@ -162,7 +162,7 @@ processType {vars} eopts nest env fc rig vis opts ty_raw ty <- wrapErrorC eopts (InType fc n) $ checkTerm idx InType (HolesOkay :: eopts) nest env - (IBindHere fc (PI erased) ty_raw.val) + (Elaboratable_Bind_Here fc (PI erased) ty_raw.val) (gType fc u) logTermNF "declare.type" 3 ("Type of " ++ show n) Env.empty (abstractFullEnvType tfc env ty) diff --git a/TTImp/Reflect.idr b/TTImp/Reflect.idr index 55d8f6ea40..f2d851763d 100644 --- a/TTImp/Reflect.idr +++ b/TTImp/Reflect.idr @@ -92,7 +92,7 @@ mutual (UN (Basic "IVar"), [fc, n]) => do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) - pure (IVar fc' n') + pure (Elaboratable_Name fc' n') (UN (Basic "IPi"), [fc, c, p, mn, aty, rty]) => do fc' <- reify defs !(evalClosure defs fc) c' <- reify defs !(evalClosure defs c) @@ -100,7 +100,7 @@ mutual mn' <- reify defs !(evalClosure defs mn) aty' <- reify defs !(evalClosure defs aty) rty' <- reify defs !(evalClosure defs rty) - pure (IPi fc' c' p' mn' aty' rty') + pure (Elaboratable_Dependent_Function_Type fc' c' p' mn' aty' rty') (UN (Basic "ILam"), [fc, c, p, mn, aty, lty]) => do fc' <- reify defs !(evalClosure defs fc) c' <- reify defs !(evalClosure defs c) @@ -108,7 +108,7 @@ mutual mn' <- reify defs !(evalClosure defs mn) aty' <- reify defs !(evalClosure defs aty) lty' <- reify defs !(evalClosure defs lty) - pure (ILam fc' c' p' mn' aty' lty') + pure (Elaboratable_Lambda fc' c' p' mn' aty' lty') (UN (Basic "ILet"), [fc, lhsFC, c, n, ty, val, sc]) => do fc' <- reify defs !(evalClosure defs fc) lhsFC' <- reify defs !(evalClosure defs lhsFC) @@ -117,120 +117,120 @@ mutual ty' <- reify defs !(evalClosure defs ty) val' <- reify defs !(evalClosure defs val) sc' <- reify defs !(evalClosure defs sc) - pure (ILet fc' lhsFC' c' n' ty' val' sc') + pure (Elaboratable_Binding fc' lhsFC' c' n' ty' val' sc') (UN (Basic "ICase"), [fc, opts, sc, ty, cs]) => do fc' <- reify defs !(evalClosure defs fc) opts' <- reify defs !(evalClosure defs opts) sc' <- reify defs !(evalClosure defs sc) ty' <- reify defs !(evalClosure defs ty) cs' <- reify defs !(evalClosure defs cs) - pure (ICase fc' opts' sc' ty' cs') + pure (Elaboratable_Case fc' opts' sc' ty' cs') (UN (Basic "ILocal"), [fc, ds, sc]) => do fc' <- reify defs !(evalClosure defs fc) ds' <- reify defs !(evalClosure defs ds) sc' <- reify defs !(evalClosure defs sc) - pure (ILocal fc' ds' sc') + pure (Elaboratable_Local_Definitions fc' ds' sc') (UN (Basic "IUpdate"), [fc, ds, sc]) => do fc' <- reify defs !(evalClosure defs fc) ds' <- reify defs !(evalClosure defs ds) sc' <- reify defs !(evalClosure defs sc) - pure (IUpdate fc' ds' sc') + pure (Elaboratable_Record_Update fc' ds' sc') (UN (Basic "IApp"), [fc, f, a]) => do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) a' <- reify defs !(evalClosure defs a) - pure (IApp fc' f' a') + pure (Elaboratable_Apply fc' f' a') (UN (Basic "INamedApp"), [fc, f, m, a]) => do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) m' <- reify defs !(evalClosure defs m) a' <- reify defs !(evalClosure defs a) - pure (INamedApp fc' f' m' a') + pure (Elaboratable_Named_Apply fc' f' m' a') (UN (Basic "IAutoApp"), [fc, f, a]) => do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) a' <- reify defs !(evalClosure defs a) - pure (IAutoApp fc' f' a') + pure (Elaboratable_Automatic_Apply fc' f' a') (UN (Basic "IWithApp"), [fc, f, a]) => do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) a' <- reify defs !(evalClosure defs a) - pure (IWithApp fc' f' a') + pure (Elaboratable_With_Apply fc' f' a') (UN (Basic "ISearch"), [fc, d]) => do fc' <- reify defs !(evalClosure defs fc) d' <- reify defs !(evalClosure defs d) - pure (ISearch fc' d') + pure (Elaboratable_Search fc' d') (UN (Basic "IAlternative"), [fc, t, as]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) as' <- reify defs !(evalClosure defs as) - pure (IAlternative fc' t' as') + pure (Elaboratable_Alternative fc' t' as') (UN (Basic "IRewrite"), [fc, t, sc]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) sc' <- reify defs !(evalClosure defs sc) - pure (IRewrite fc' t' sc') + pure (Elaboratable_Rewrite fc' t' sc') (UN (Basic "IBindHere"), [fc, t, sc]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) sc' <- reify defs !(evalClosure defs sc) - pure (IBindHere fc' t' sc') + pure (Elaboratable_Bind_Here fc' t' sc') (UN (Basic "IBindVar"), [fc, n]) => do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) - pure (IBindVar fc' n') + pure (Elaboratable_Bind_Name fc' n') (UN (Basic "IAs"), [fc, nameFC, s, n, t]) => do fc' <- reify defs !(evalClosure defs fc) nameFC' <- reify defs !(evalClosure defs nameFC) s' <- reify defs !(evalClosure defs s) n' <- reify defs !(evalClosure defs n) t' <- reify defs !(evalClosure defs t) - pure (IAs fc' nameFC' s' n' t') + pure (Elaboratable_As_Pattern fc' nameFC' s' n' t') (UN (Basic "IMustUnify"), [fc, r, t]) => do fc' <- reify defs !(evalClosure defs fc) r' <- reify defs !(evalClosure defs r) t' <- reify defs !(evalClosure defs t) - pure (IMustUnify fc' r' t') + pure (Elaboratable_Must_Unify fc' r' t') (UN (Basic "IDelayed"), [fc, r, t]) => do fc' <- reify defs !(evalClosure defs fc) r' <- reify defs !(evalClosure defs r) t' <- reify defs !(evalClosure defs t) - pure (IDelayed fc' r' t') + pure (Elaboratable_Delayed_Type fc' r' t') (UN (Basic "IDelay"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (IDelay fc' t') + pure (Elaboratable_Delay fc' t') (UN (Basic "IForce"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (IForce fc' t') + pure (Elaboratable_Force fc' t') (UN (Basic "IQuote"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (IQuote fc' t') + pure (Elaboratable_Quote fc' t') (UN (Basic "IQuoteName"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (IQuoteName fc' t') + pure (Elaboratable_Quote_Name fc' t') (UN (Basic "IQuoteDecl"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (IQuoteDecl fc' t') + pure (Elaboratable_Quote_Declarations fc' t') (UN (Basic "IUnquote"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (IUnquote fc' t') + pure (Elaboratable_Unquote fc' t') (UN (Basic "IPrimVal"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (IPrimVal fc' t') + pure (Elaboratable_Primitive_Value fc' t') (UN (Basic "IType"), [fc]) => do fc' <- reify defs !(evalClosure defs fc) - pure (IType fc') + pure (Elaboratable_Type_Universe fc') (UN (Basic "IHole"), [fc, n]) => do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) - pure (IHole fc' n') + pure (Elaboratable_Hole fc' n') (UN (Basic "Implicit"), [fc, n]) => do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) @@ -239,22 +239,22 @@ mutual => do fc' <- reify defs !(evalClosure defs fc) ns' <- reify defs !(evalClosure defs ns) t' <- reify defs !(evalClosure defs t) - pure (IWithUnambigNames fc' ns' t') + pure (Elaboratable_With_Unambiguous_Names fc' ns' t') _ => cantReify val "TTImp" reify defs val = cantReify val "TTImp" export - Reify IFieldUpdate where + Reify Elaboratable_Field_Update where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of (UN (Basic "ISetField"), [(_, x), (_, y)]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) - pure (ISetField x' y') + pure (Elaboratable_Set_Field x' y') (UN (Basic "ISetFieldApp"), [(_, x), (_, y)]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) - pure (ISetFieldApp x' y') + pure (Elaboratable_Apply_To_Field x' y') _ => cantReify val "IFieldUpdate" reify defs val = cantReify val "IFieldUpdate" @@ -351,7 +351,7 @@ mutual reify defs val = cantReify val "Data" export - Reify IField where + Reify Elaboratable_Field where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of (UN (Basic "MkIField"), [v,w,x,y,z]) @@ -415,7 +415,7 @@ mutual reify defs val = cantReify val "Clause" export - Reify (IClaimData Name) where + Reify (Elaboratable_Claim_Data Name) where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of (UN (Basic "MkIClaimData"), [w, x, y, z]) @@ -423,7 +423,7 @@ mutual x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) - pure (MkIClaimData w' x' y' z') + pure (Make_Elaboratable_Claim_Data w' x' y' z') _ => cantReify val "IClaimData" reify defs val = cantReify val "IClaimData" @@ -433,60 +433,60 @@ mutual = case (dropAllNS !(full (gamma defs) n), map snd args) of (UN (Basic "IClaim"), [v]) => do v' <- reify defs !(evalClosure defs v) - pure (IClaim v') + pure (Elaboratable_Claim v') (UN (Basic "IData"), [x,y,z,w]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) w' <- reify defs !(evalClosure defs w) - pure (IData x' y' z' w') + pure (Elaboratable_Data_Declaration x' y' z' w') (UN (Basic "IDef"), [x,y,z]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) - pure (IDef x' y' z') + pure (Elaboratable_Definition x' y' z') (UN (Basic "IParameters"), [x,y,z]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) - pure (IParameters x' (map fromOldParams y') z') + pure (Elaboratable_Parameter_Block x' (map fromOldParams y') z') (UN (Basic "IRecord"), [w,x,y,z,u]) => do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) u' <- reify defs !(evalClosure defs u) - pure (IRecord w' x' y' z' u') + pure (Elaboratable_Record_Declaration w' x' y' z' u') (UN (Basic "IFail"), [w,x,y]) => do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) - pure (IFail w' x' y') + pure (Elaboratable_Expected_Failure w' x' y') (UN (Basic "INamespace"), [w,x,y]) => do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) - pure (INamespace w' x' y') + pure (Elaboratable_Namespace_Block w' x' y') (UN (Basic "ITransform"), [w,x,y,z]) => do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) - pure (ITransform w' x' y' z') + pure (Elaboratable_Transformation w' x' y' z') (UN (Basic "ILog"), [x]) => do x' <- reify defs !(evalClosure defs x) - pure (ILog x') + pure (Elaboratable_Logging x') _ => cantReify val "Decl" reify defs val = cantReify val "Decl" mutual export Reflect RawImp where - reflect fc defs lhs env (IVar tfc n) + reflect fc defs lhs env (Elaboratable_Name tfc n) = do fc' <- reflect fc defs lhs env tfc n' <- reflect fc defs lhs env n appCon fc defs (reflectionttimp "IVar") [fc', n'] - reflect fc defs lhs env (IPi tfc c p mn aty rty) + reflect fc defs lhs env (Elaboratable_Dependent_Function_Type tfc c p mn aty rty) = do fc' <- reflect fc defs lhs env tfc c' <- reflect fc defs lhs env c p' <- reflect fc defs lhs env p @@ -494,7 +494,7 @@ mutual aty' <- reflect fc defs lhs env aty rty' <- reflect fc defs lhs env rty appCon fc defs (reflectionttimp "IPi") [fc', c', p', mn', aty', rty'] - reflect fc defs lhs env (ILam tfc c p mn aty rty) + reflect fc defs lhs env (Elaboratable_Lambda tfc c p mn aty rty) = do fc' <- reflect fc defs lhs env tfc c' <- reflect fc defs lhs env c p' <- reflect fc defs lhs env p @@ -502,7 +502,7 @@ mutual aty' <- reflect fc defs lhs env aty rty' <- reflect fc defs lhs env rty appCon fc defs (reflectionttimp "ILam") [fc', c', p', mn', aty', rty'] - reflect fc defs lhs env (ILet tfc lhsFC c n aty aval sc) + reflect fc defs lhs env (Elaboratable_Binding tfc lhsFC c n aty aval sc) = do fc' <- reflect fc defs lhs env tfc lhsFC' <- reflect fc defs lhs env lhsFC c' <- reflect fc defs lhs env c @@ -511,125 +511,125 @@ mutual aval' <- reflect fc defs lhs env aval sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "ILet") [fc', lhsFC', c', n', aty', aval', sc'] - reflect fc defs lhs env (ICase tfc opts sc ty cs) + reflect fc defs lhs env (Elaboratable_Case tfc opts sc ty cs) = do fc' <- reflect fc defs lhs env tfc opts' <- reflect fc defs lhs env opts sc' <- reflect fc defs lhs env sc ty' <- reflect fc defs lhs env ty cs' <- reflect fc defs lhs env cs appCon fc defs (reflectionttimp "ICase") [fc', opts', sc', ty', cs'] - reflect fc defs lhs env (ILocal tfc ds sc) + reflect fc defs lhs env (Elaboratable_Local_Definitions tfc ds sc) = do fc' <- reflect fc defs lhs env tfc ds' <- reflect fc defs lhs env ds sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "ILocal") [fc', ds', sc'] - reflect fc defs lhs env (ICaseLocal tfc u i args t) + reflect fc defs lhs env (Elaboratable_Case_Local_Definition tfc u i args t) = reflect fc defs lhs env t -- shouldn't see this anyway... - reflect fc defs lhs env (IUpdate tfc ds sc) + reflect fc defs lhs env (Elaboratable_Record_Update tfc ds sc) = do fc' <- reflect fc defs lhs env tfc ds' <- reflect fc defs lhs env ds sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "IUpdate") [fc', ds', sc'] - reflect fc defs lhs env (IApp tfc f a) + reflect fc defs lhs env (Elaboratable_Apply tfc f a) = do fc' <- reflect fc defs lhs env tfc f' <- reflect fc defs lhs env f a' <- reflect fc defs lhs env a appCon fc defs (reflectionttimp "IApp") [fc', f', a'] - reflect fc defs lhs env (IAutoApp tfc f a) + reflect fc defs lhs env (Elaboratable_Automatic_Apply tfc f a) = do fc' <- reflect fc defs lhs env tfc f' <- reflect fc defs lhs env f a' <- reflect fc defs lhs env a appCon fc defs (reflectionttimp "IAutoApp") [fc', f', a'] - reflect fc defs lhs env (INamedApp tfc f m a) + reflect fc defs lhs env (Elaboratable_Named_Apply tfc f m a) = do fc' <- reflect fc defs lhs env tfc f' <- reflect fc defs lhs env f m' <- reflect fc defs lhs env m a' <- reflect fc defs lhs env a appCon fc defs (reflectionttimp "INamedApp") [fc', f', m', a'] - reflect fc defs lhs env (IWithApp tfc f a) + reflect fc defs lhs env (Elaboratable_With_Apply tfc f a) = do fc' <- reflect fc defs lhs env tfc f' <- reflect fc defs lhs env f a' <- reflect fc defs lhs env a appCon fc defs (reflectionttimp "IWithApp") [fc', f', a'] - reflect fc defs lhs env (ISearch tfc d) + reflect fc defs lhs env (Elaboratable_Search tfc d) = do fc' <- reflect fc defs lhs env tfc d' <- reflect fc defs lhs env d appCon fc defs (reflectionttimp "ISearch") [fc', d'] - reflect fc defs lhs env (IAlternative tfc t as) + reflect fc defs lhs env (Elaboratable_Alternative tfc t as) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t as' <- reflect fc defs lhs env as appCon fc defs (reflectionttimp "IAlternative") [fc', t', as'] - reflect fc defs lhs env (IRewrite tfc t sc) + reflect fc defs lhs env (Elaboratable_Rewrite tfc t sc) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "IRewrite") [fc', t', sc'] - reflect fc defs lhs env (ICoerced tfc d) = reflect fc defs lhs env d - reflect fc defs lhs env (IBindHere tfc n sc) + reflect fc defs lhs env (Elaboratable_Coerced tfc d) = reflect fc defs lhs env d + reflect fc defs lhs env (Elaboratable_Bind_Here tfc n sc) = do fc' <- reflect fc defs lhs env tfc n' <- reflect fc defs lhs env n sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "IBindHere") [fc', n', sc'] - reflect fc defs lhs env (IBindVar tfc n) + reflect fc defs lhs env (Elaboratable_Bind_Name tfc n) = do fc' <- reflect fc defs lhs env tfc n' <- reflect fc defs lhs env n appCon fc defs (reflectionttimp "IBindVar") [fc', n'] - reflect fc defs lhs env (IAs tfc nameFC s n t) + reflect fc defs lhs env (Elaboratable_As_Pattern tfc nameFC s n t) = do fc' <- reflect fc defs lhs env tfc nameFC' <- reflect fc defs lhs env nameFC s' <- reflect fc defs lhs env s n' <- reflect fc defs lhs env n t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IAs") [fc', nameFC', s', n', t'] - reflect fc defs lhs env (IMustUnify tfc r t) + reflect fc defs lhs env (Elaboratable_Must_Unify tfc r t) = do fc' <- reflect fc defs lhs env tfc r' <- reflect fc defs lhs env r t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IMustUnify") [fc', r', t'] - reflect fc defs lhs env (IDelayed tfc r t) + reflect fc defs lhs env (Elaboratable_Delayed_Type tfc r t) = do fc' <- reflect fc defs lhs env tfc r' <- reflect fc defs lhs env r t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IDelayed") [fc', r', t'] - reflect fc defs lhs env (IDelay tfc t) + reflect fc defs lhs env (Elaboratable_Delay tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IDelay") [fc', t'] - reflect fc defs lhs env (IForce tfc t) + reflect fc defs lhs env (Elaboratable_Force tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IForce") [fc', t'] - reflect fc defs lhs env (IQuote tfc t) + reflect fc defs lhs env (Elaboratable_Quote tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IQuote") [fc', t'] - reflect fc defs lhs env (IQuoteName tfc t) + reflect fc defs lhs env (Elaboratable_Quote_Name tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IQuoteName") [fc', t'] - reflect fc defs lhs env (IQuoteDecl tfc t) + reflect fc defs lhs env (Elaboratable_Quote_Declarations tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IQuoteDecl") [fc', t'] - reflect fc defs lhs env (IUnquote tfc (IVar _ t)) + reflect fc defs lhs env (Elaboratable_Unquote tfc (Elaboratable_Name _ t)) = pure (Ref tfc Bound t) - reflect fc defs lhs env (IUnquote tfc t) + reflect fc defs lhs env (Elaboratable_Unquote tfc t) = throw (InternalError "Can't reflect an unquote: escapes should be lifted out") - reflect fc defs lhs env (IRunElab tfc _ t) + reflect fc defs lhs env (Elaboratable_Run_Elaborator tfc _ t) = throw (InternalError "Can't reflect a %runElab") - reflect fc defs lhs env (IPrimVal tfc t) + reflect fc defs lhs env (Elaboratable_Primitive_Value tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IPrimVal") [fc', t'] - reflect fc defs lhs env (IType tfc) + reflect fc defs lhs env (Elaboratable_Type_Universe tfc) = do fc' <- reflect fc defs lhs env tfc appCon fc defs (reflectionttimp "IType") [fc'] - reflect fc defs lhs env (IHole tfc t) + reflect fc defs lhs env (Elaboratable_Hole tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IHole") [fc', t'] - reflect fc defs lhs env (IUnifyLog tfc _ t) + reflect fc defs lhs env (Elaboratable_Unification_Log tfc _ t) = reflect fc defs lhs env t reflect fc defs True env (Implicit tfc t) = pure (Erased fc Placeholder) @@ -637,19 +637,19 @@ mutual = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "Implicit") [fc', t'] - reflect fc defs lhs env (IWithUnambigNames tfc ns t) + reflect fc defs lhs env (Elaboratable_With_Unambiguous_Names tfc ns t) = do fc' <- reflect fc defs lhs env tfc ns' <- reflect fc defs lhs env ns t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IWithUnambigNames") [fc', ns', t'] export - Reflect IFieldUpdate where - reflect fc defs lhs env (ISetField p t) + Reflect Elaboratable_Field_Update where + reflect fc defs lhs env (Elaboratable_Set_Field p t) = do p' <- reflect fc defs lhs env p t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "ISetField") [p', t'] - reflect fc defs lhs env (ISetFieldApp p t) + reflect fc defs lhs env (Elaboratable_Apply_To_Field p t) = do p' <- reflect fc defs lhs env p t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "ISetFieldApp") [p', t'] @@ -725,7 +725,7 @@ mutual appCon fc defs (reflectionttimp "MkLater") [x', y', z'] export - Reflect IField where + Reflect Elaboratable_Field where reflect fc defs lhs env field -- Order matters to maintain compatibility with elab reflection = do v' <- reflect fc defs lhs env field.fc w' <- reflect fc defs lhs env field.rig @@ -771,8 +771,8 @@ mutual appCon fc defs (reflectionttimp "ImpossibleClause") [x', y'] export - Reflect (IClaimData Name) where - reflect fc defs lhs env (MkIClaimData w x y z) + Reflect (Elaboratable_Claim_Data Name) where + reflect fc defs lhs env (Make_Elaboratable_Claim_Data w x y z) = do w' <- reflect fc defs lhs env w x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y @@ -781,54 +781,54 @@ mutual export Reflect ImpDecl where - reflect fc defs lhs env (IClaim v) + reflect fc defs lhs env (Elaboratable_Claim v) = do v' <- reflect fc defs lhs env v appCon fc defs (reflectionttimp "IClaim") [v'] - reflect fc defs lhs env (IData x y z w) + reflect fc defs lhs env (Elaboratable_Data_Declaration x y z w) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z w' <- reflect fc defs lhs env w appCon fc defs (reflectionttimp "IData") [x', y', z', w'] - reflect fc defs lhs env (IDef x y z) + reflect fc defs lhs env (Elaboratable_Definition x y z) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "IDef") [x', y', z'] - reflect fc defs lhs env (IParameters x y z) + reflect fc defs lhs env (Elaboratable_Parameter_Block x y z) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env (map toOldParams y) z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "IParameters") [x', y', z'] - reflect fc defs lhs env (IRecord w x y z u) + reflect fc defs lhs env (Elaboratable_Record_Declaration w x y z u) = do w' <- reflect fc defs lhs env w x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z u' <- reflect fc defs lhs env u appCon fc defs (reflectionttimp "IRecord") [w', x', y', z', u'] - reflect fc defs lhs env (IFail x y z) + reflect fc defs lhs env (Elaboratable_Expected_Failure x y z) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "IFail") [x', y', z'] - reflect fc defs lhs env (INamespace x y z) + reflect fc defs lhs env (Elaboratable_Namespace_Block x y z) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "INamespace") [x', y', z'] - reflect fc defs lhs env (ITransform w x y z) + reflect fc defs lhs env (Elaboratable_Transformation w x y z) = do w' <- reflect fc defs lhs env w x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "ITransform") [w', x', y', z'] - reflect fc defs lhs env (IRunElabDecl w x) + reflect fc defs lhs env (Elaboratable_Run_Elaborator_Declaration w x) = throw (GenericMsg fc "Can't reflect a %runElab") - reflect fc defs lhs env (IPragma _ _ x) + reflect fc defs lhs env (Elaboratable_Pragma _ _ x) = throw (GenericMsg fc "Can't reflect a pragma") - reflect fc defs lhs env (ILog x) + reflect fc defs lhs env (Elaboratable_Logging x) = do x' <- reflect fc defs lhs env x appCon fc defs (reflectionttimp "ILog") [x'] - reflect fc defs lhs env (IBuiltin {}) + reflect fc defs lhs env (Elaboratable_Builtin_Declaration {}) = throw (GenericMsg fc "Can't reflect a %builtin") diff --git a/TTImp/TTImp.idr b/TTImp/TTImp.idr index 708ad50664..3cefcf3312 100644 --- a/TTImp/TTImp.idr +++ b/TTImp/TTImp.idr @@ -58,89 +58,89 @@ mutual RawImp = RawImp' Name public export - IRawImp : Type - IRawImp = RawImp' KindedName + Kinded_Elaboratable_Term : Type + Kinded_Elaboratable_Term = RawImp' KindedName public export data RawImp' : Type -> Type where - IVar : FC -> nm -> RawImp' nm - IPi : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> + Elaboratable_Name : FC -> nm -> RawImp' nm + Elaboratable_Dependent_Function_Type : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> (argTy : RawImp' nm) -> (retTy : RawImp' nm) -> RawImp' nm - ILam : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> + Elaboratable_Lambda : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> (argTy : RawImp' nm) -> (lamTy : RawImp' nm) -> RawImp' nm - ILet : FC -> (lhsFC : FC) -> RigCount -> Name -> + Elaboratable_Binding : FC -> (lhsFC : FC) -> RigCount -> Name -> (nTy : RawImp' nm) -> (nVal : RawImp' nm) -> (scope : RawImp' nm) -> RawImp' nm - ICase : FC -> List (FnOpt' nm) -> RawImp' nm -> (ty : RawImp' nm) -> + Elaboratable_Case : FC -> List (FnOpt' nm) -> RawImp' nm -> (ty : RawImp' nm) -> List (ImpClause' nm) -> RawImp' nm - ILocal : FC -> List (ImpDecl' nm) -> RawImp' nm -> RawImp' nm + Elaboratable_Local_Definitions : FC -> List (ImpDecl' nm) -> RawImp' nm -> RawImp' nm -- Local definitions made elsewhere, but that we're pushing -- into a case branch as nested names. -- An appearance of 'uname' maps to an application of -- 'internalName' to 'args'. - ICaseLocal : FC -> (uname : Name) -> + Elaboratable_Case_Local_Definition : FC -> (uname : Name) -> (internalName : Name) -> (args : List Name) -> RawImp' nm -> RawImp' nm - IUpdate : FC -> List (IFieldUpdate' nm) -> RawImp' nm -> RawImp' nm + Elaboratable_Record_Update : FC -> List (Elaboratable_Field_Update' nm) -> RawImp' nm -> RawImp' nm - IApp : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm - IAutoApp : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm - INamedApp : FC -> RawImp' nm -> Name -> RawImp' nm -> RawImp' nm - IWithApp : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm + Elaboratable_Apply : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm + Elaboratable_Automatic_Apply : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm + Elaboratable_Named_Apply : FC -> RawImp' nm -> Name -> RawImp' nm -> RawImp' nm + Elaboratable_With_Apply : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm - ISearch : FC -> (depth : Nat) -> RawImp' nm - IAlternative : FC -> AltType' nm -> List (RawImp' nm) -> RawImp' nm - IRewrite : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm - ICoerced : FC -> RawImp' nm -> RawImp' nm + Elaboratable_Search : FC -> (depth : Nat) -> RawImp' nm + Elaboratable_Alternative : FC -> AltType' nm -> List (RawImp' nm) -> RawImp' nm + Elaboratable_Rewrite : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm + Elaboratable_Coerced : FC -> RawImp' nm -> RawImp' nm -- Any implicit bindings in the scope should be bound here, using -- the given binder - IBindHere : FC -> BindMode -> RawImp' nm -> RawImp' nm + Elaboratable_Bind_Here : FC -> BindMode -> RawImp' nm -> RawImp' nm -- A name which should be implicitly bound - IBindVar : FC -> Name -> RawImp' nm + Elaboratable_Bind_Name : FC -> Name -> RawImp' nm -- An 'as' pattern, valid on the LHS of a clause only - IAs : FC -> (nameFC : FC) -> UseSide -> Name -> RawImp' nm -> RawImp' nm + Elaboratable_As_Pattern : FC -> (nameFC : FC) -> UseSide -> Name -> RawImp' nm -> RawImp' nm -- A 'dot' pattern, i.e. one which must also have the given value -- by unification - IMustUnify : FC -> DotReason -> RawImp' nm -> RawImp' nm + Elaboratable_Must_Unify : FC -> DotReason -> RawImp' nm -> RawImp' nm -- Laziness annotations - IDelayed : FC -> LazyReason -> RawImp' nm -> RawImp' nm -- the type - IDelay : FC -> RawImp' nm -> RawImp' nm -- delay constructor - IForce : FC -> RawImp' nm -> RawImp' nm + Elaboratable_Delayed_Type : FC -> LazyReason -> RawImp' nm -> RawImp' nm -- the type + Elaboratable_Delay : FC -> RawImp' nm -> RawImp' nm -- delay constructor + Elaboratable_Force : FC -> RawImp' nm -> RawImp' nm -- Quasiquoting - IQuote : FC -> RawImp' nm -> RawImp' nm - IQuoteName : FC -> Name -> RawImp' nm - IQuoteDecl : FC -> List (ImpDecl' nm) -> RawImp' nm - IUnquote : FC -> RawImp' nm -> RawImp' nm - IRunElab : FC -> (requireExtension : Bool) -> RawImp' nm -> RawImp' nm + Elaboratable_Quote : FC -> RawImp' nm -> RawImp' nm + Elaboratable_Quote_Name : FC -> Name -> RawImp' nm + Elaboratable_Quote_Declarations : FC -> List (ImpDecl' nm) -> RawImp' nm + Elaboratable_Unquote : FC -> RawImp' nm -> RawImp' nm + Elaboratable_Run_Elaborator : FC -> (requireExtension : Bool) -> RawImp' nm -> RawImp' nm - IPrimVal : FC -> (c : Constant) -> RawImp' nm - IType : FC -> RawImp' nm - IHole : FC -> String -> RawImp' nm + Elaboratable_Primitive_Value : FC -> (c : Constant) -> RawImp' nm + Elaboratable_Type_Universe : FC -> RawImp' nm + Elaboratable_Hole : FC -> String -> RawImp' nm - IUnifyLog : FC -> LogLevel -> RawImp' nm -> RawImp' nm + Elaboratable_Unification_Log : FC -> LogLevel -> RawImp' nm -> RawImp' nm -- An implicit value, solved by unification, but which will also be -- bound (either as a pattern variable or a type variable) if unsolved -- at the end of elaborator Implicit : FC -> (bindIfUnsolved : Bool) -> RawImp' nm -- with-disambiguation - IWithUnambigNames : FC -> List (FC, Name) -> RawImp' nm -> RawImp' nm + Elaboratable_With_Unambiguous_Names : FC -> List (FC, Name) -> RawImp' nm -> RawImp' nm %name RawImp' t, u public export - IFieldUpdate : Type - IFieldUpdate = IFieldUpdate' Name + Elaboratable_Field_Update : Type + Elaboratable_Field_Update = Elaboratable_Field_Update' Name public export - data IFieldUpdate' : Type -> Type where - ISetField : (path : List String) -> RawImp' nm -> IFieldUpdate' nm - ISetFieldApp : (path : List String) -> RawImp' nm -> IFieldUpdate' nm - %name IFieldUpdate' upd + data Elaboratable_Field_Update' : Type -> Type where + Elaboratable_Set_Field : (path : List String) -> RawImp' nm -> Elaboratable_Field_Update' nm + Elaboratable_Apply_To_Field : (path : List String) -> RawImp' nm -> Elaboratable_Field_Update' nm + %name Elaboratable_Field_Update' upd public export AltType : Type @@ -156,67 +156,67 @@ mutual export covering Show nm => Show (RawImp' nm) where - show (IVar fc n) = show n - show (IPi fc c p n arg ret) + show (Elaboratable_Name fc n) = show n + show (Elaboratable_Dependent_Function_Type fc c p n arg ret) = "(%pi " ++ show c ++ " " ++ show p ++ " " ++ showPrec App n ++ " " ++ show arg ++ " " ++ show ret ++ ")" - show (ILam fc c p n arg sc) + show (Elaboratable_Lambda fc c p n arg sc) = "(%lam " ++ show c ++ " " ++ show p ++ " " ++ showPrec App n ++ " " ++ show arg ++ " " ++ show sc ++ ")" - show (ILet fc lhsFC c n ty val sc) + show (Elaboratable_Binding fc lhsFC c n ty val sc) = "(%let " ++ show c ++ " " ++ " " ++ show n ++ " " ++ show ty ++ " " ++ show val ++ " " ++ show sc ++ ")" - show (ICase _ _ scr scrty alts) + show (Elaboratable_Case _ _ scr scrty alts) = "(%case (" ++ show scr ++ " : " ++ show scrty ++ ") " ++ show alts ++ ")" - show (ILocal _ def scope) + show (Elaboratable_Local_Definitions _ def scope) = "(%local (" ++ show def ++ ") " ++ show scope ++ ")" - show (ICaseLocal _ uname iname args sc) + show (Elaboratable_Case_Local_Definition _ uname iname args sc) = "(%caselocal (" ++ show uname ++ " " ++ show iname ++ " " ++ show args ++ ") " ++ show sc ++ ")" - show (IUpdate _ flds rec) + show (Elaboratable_Record_Update _ flds rec) = "(%record " ++ showSep ", " (map show flds) ++ " " ++ show rec ++ ")" - show (IApp fc f a) + show (Elaboratable_Apply fc f a) = "(" ++ show f ++ " " ++ show a ++ ")" - show (INamedApp fc f n a) + show (Elaboratable_Named_Apply fc f n a) = "(" ++ show f ++ " [" ++ show n ++ " = " ++ show a ++ "])" - show (IAutoApp fc f a) + show (Elaboratable_Automatic_Apply fc f a) = "(" ++ show f ++ " [" ++ show a ++ "])" - show (IWithApp fc f a) + show (Elaboratable_With_Apply fc f a) = "(" ++ show f ++ " | " ++ show a ++ ")" - show (ISearch fc d) + show (Elaboratable_Search fc d) = "%search" - show (IAlternative fc ty alts) + show (Elaboratable_Alternative fc ty alts) = "(|" ++ showSep "," (map show alts) ++ "|)" - show (IRewrite _ rule tm) + show (Elaboratable_Rewrite _ rule tm) = "(%rewrite (" ++ show rule ++ ") (" ++ show tm ++ "))" - show (ICoerced _ tm) = "(%coerced " ++ show tm ++ ")" + show (Elaboratable_Coerced _ tm) = "(%coerced " ++ show tm ++ ")" - show (IBindHere fc b sc) + show (Elaboratable_Bind_Here fc b sc) = "(%bindhere " ++ show sc ++ ")" - show (IBindVar fc n) = "$" ++ show n - show (IAs fc _ _ n tm) = show n ++ "@(" ++ show tm ++ ")" - show (IMustUnify fc r tm) = ".(" ++ show tm ++ ")" - show (IDelayed fc r tm) = "(%delayed " ++ show tm ++ ")" - show (IDelay fc tm) = "(%delay " ++ show tm ++ ")" - show (IForce fc tm) = "(%force " ++ show tm ++ ")" - show (IQuote fc tm) = "(%quote " ++ show tm ++ ")" - show (IQuoteName fc tm) = "(%quotename " ++ show tm ++ ")" - show (IQuoteDecl fc tm) = "(%quotedecl " ++ show tm ++ ")" - show (IUnquote fc tm) = "(%unquote " ++ show tm ++ ")" - show (IRunElab fc _ tm) = "(%runelab " ++ show tm ++ ")" - show (IPrimVal fc c) = show c - show (IHole _ x) = "?" ++ x - show (IUnifyLog _ lvl x) = "(%logging " ++ show lvl ++ " " ++ show x ++ ")" - show (IType fc) = "%type" + show (Elaboratable_Bind_Name fc n) = "$" ++ show n + show (Elaboratable_As_Pattern fc _ _ n tm) = show n ++ "@(" ++ show tm ++ ")" + show (Elaboratable_Must_Unify fc r tm) = ".(" ++ show tm ++ ")" + show (Elaboratable_Delayed_Type fc r tm) = "(%delayed " ++ show tm ++ ")" + show (Elaboratable_Delay fc tm) = "(%delay " ++ show tm ++ ")" + show (Elaboratable_Force fc tm) = "(%force " ++ show tm ++ ")" + show (Elaboratable_Quote fc tm) = "(%quote " ++ show tm ++ ")" + show (Elaboratable_Quote_Name fc tm) = "(%quotename " ++ show tm ++ ")" + show (Elaboratable_Quote_Declarations fc tm) = "(%quotedecl " ++ show tm ++ ")" + show (Elaboratable_Unquote fc tm) = "(%unquote " ++ show tm ++ ")" + show (Elaboratable_Run_Elaborator fc _ tm) = "(%runelab " ++ show tm ++ ")" + show (Elaboratable_Primitive_Value fc c) = show c + show (Elaboratable_Hole _ x) = "?" ++ x + show (Elaboratable_Unification_Log _ lvl x) = "(%logging " ++ show lvl ++ " " ++ show x ++ ")" + show (Elaboratable_Type_Universe fc) = "%type" show (Implicit fc True) = "_" show (Implicit fc False) = "?" - show (IWithUnambigNames fc ns rhs) = "(%with " ++ show ns ++ " " ++ show rhs ++ ")" + show (Elaboratable_With_Unambiguous_Names fc ns rhs) = "(%with " ++ show ns ++ " " ++ show rhs ++ ")" export covering - Show nm => Show (IFieldUpdate' nm) where - show (ISetField p val) = showSep "->" p ++ " = " ++ show val - show (ISetFieldApp p val) = showSep "->" p ++ " $= " ++ show val + Show nm => Show (Elaboratable_Field_Update' nm) where + show (Elaboratable_Set_Field p val) = showSep "->" p ++ " = " ++ show val + show (Elaboratable_Apply_To_Field p val) = showSep "->" p ++ " $= " ++ show val public export FnOpt : Type @@ -338,12 +338,12 @@ mutual = "(%datadecl " ++ show n ++ " " ++ show tycon ++ ")" public export - IField : Type - IField = IField' Name + Elaboratable_Field : Type + Elaboratable_Field = Elaboratable_Field' Name public export - IField' : Type -> Type - IField' nm = AddFC $ ImpParameter' (RawImp' nm) + Elaboratable_Field' : Type -> Type + Elaboratable_Field' nm = AddFC $ ImpParameter' (RawImp' nm) public export ImpParameter : Type @@ -380,7 +380,7 @@ mutual public export 0 RecordBody : Type -> Type -- The name is the data constructor's name - RecordBody nm = WithName $ WithOpts $ List (IField' nm) + RecordBody nm = WithName $ WithOpts $ List (Elaboratable_Field' nm) ||| A record is defined by its header containing the name and parameters, and its body ||| containing the constructor name, options, and a list of fields @@ -392,7 +392,7 @@ mutual export covering - Show nm => Show (IField' nm) where + Show nm => Show (Elaboratable_Field' nm) where show f@(MkWithData _ (MkPiBindData Explicit ty)) = show f.name.val ++ " : " ++ show ty show f@(MkWithData _ ty) = "{" ++ show f.name.val ++ " : " ++ show ty.boundType ++ "}" @@ -417,8 +417,8 @@ mutual ImpClause = ImpClause' Name public export - IImpClause : Type - IImpClause = ImpClause' KindedName + Kinded_Elaboratable_Clause : Type + Kinded_Elaboratable_Clause = ImpClause' KindedName public export data ImpClause' : Type -> Type where @@ -451,8 +451,8 @@ mutual ImpDecl = ImpDecl' Name public export - record IClaimData (nm : Type) where - constructor MkIClaimData + record Elaboratable_Claim_Data (nm : Type) where + constructor Make_Elaboratable_Claim_Data rig : RigCount vis : Visibility opts : List (FnOpt' nm) @@ -460,60 +460,60 @@ mutual public export data ImpDecl' : Type -> Type where - IClaim : WithFC (IClaimData nm) -> ImpDecl' nm - IData : FC -> WithDefault Visibility Private -> + Elaboratable_Claim : WithFC (Elaboratable_Claim_Data nm) -> ImpDecl' nm + Elaboratable_Data_Declaration : FC -> WithDefault Visibility Private -> Maybe TotalReq -> ImpData' nm -> ImpDecl' nm - IDef : FC -> Name -> List (ImpClause' nm) -> ImpDecl' nm - IParameters : FC -> + Elaboratable_Definition : FC -> Name -> List (ImpClause' nm) -> ImpDecl' nm + Elaboratable_Parameter_Block : FC -> List1 (ImpParameter' (RawImp' nm)) -> List (ImpDecl' nm) -> ImpDecl' nm - IRecord : FC -> + Elaboratable_Record_Declaration : FC -> Maybe String -> -- nested namespace WithDefault Visibility Private -> Maybe TotalReq -> AddFC (ImpRecordData nm) -> ImpDecl' nm - IFail : FC -> Maybe String -> List (ImpDecl' nm) -> ImpDecl' nm - INamespace : FC -> Namespace -> List (ImpDecl' nm) -> ImpDecl' nm - ITransform : FC -> Name -> RawImp' nm -> RawImp' nm -> ImpDecl' nm - IRunElabDecl : FC -> RawImp' nm -> ImpDecl' nm - IPragma : FC -> List Name -> -- pragmas might define names that wouldn't + Elaboratable_Expected_Failure : FC -> Maybe String -> List (ImpDecl' nm) -> ImpDecl' nm + Elaboratable_Namespace_Block : FC -> Namespace -> List (ImpDecl' nm) -> ImpDecl' nm + Elaboratable_Transformation : FC -> Name -> RawImp' nm -> RawImp' nm -> ImpDecl' nm + Elaboratable_Run_Elaborator_Declaration : FC -> RawImp' nm -> ImpDecl' nm + Elaboratable_Pragma : FC -> List Name -> -- pragmas might define names that wouldn't -- otherwise be spotted in 'definedInBlock' so they -- can be flagged here. ({vars : _} -> NestedNames vars -> Env Term vars -> Core ()) -> ImpDecl' nm - ILog : Maybe (List String, Nat) -> ImpDecl' nm - IBuiltin : FC -> BuiltinType -> Name -> ImpDecl' nm + Elaboratable_Logging : Maybe (List String, Nat) -> ImpDecl' nm + Elaboratable_Builtin_Declaration : FC -> BuiltinType -> Name -> ImpDecl' nm %name ImpDecl' decl export covering Show nm => Show (ImpDecl' nm) where - show (IClaim (MkWithData _ $ MkIClaimData c _ opts ty)) + show (Elaboratable_Claim (MkWithData _ $ Make_Elaboratable_Claim_Data c _ opts ty)) = show opts ++ " " ++ show c ++ " " ++ show ty - show (IData _ _ _ d) = show d - show (IDef _ n cs) = "(%def " ++ show n ++ " " ++ show cs ++ ")" - show (IParameters _ ps ds) + show (Elaboratable_Data_Declaration _ _ _ d) = show d + show (Elaboratable_Definition _ n cs) = "(%def " ++ show n ++ " " ++ show cs ++ ")" + show (Elaboratable_Parameter_Block _ ps ds) = "parameters " ++ show ps ++ "\n\t" ++ showSep "\n\t" (assert_total $ map show ds) - show (IRecord _ _ _ _ d) = show d.val - show (IFail _ msg decls) + show (Elaboratable_Record_Declaration _ _ _ _ d) = show d.val + show (Elaboratable_Expected_Failure _ msg decls) = "fail" ++ maybe "" ((" " ++) . show) msg ++ "\n" ++ showSep "\n" (assert_total $ map ((" " ++) . show) decls) - show (INamespace _ ns decls) + show (Elaboratable_Namespace_Block _ ns decls) = "namespace " ++ show ns ++ showSep "\n" (assert_total $ map show decls) - show (ITransform _ n lhs rhs) + show (Elaboratable_Transformation _ n lhs rhs) = "%transform " ++ show n ++ " " ++ show lhs ++ " ==> " ++ show rhs - show (IRunElabDecl _ tm) + show (Elaboratable_Run_Elaborator_Declaration _ tm) = "%runElab " ++ show tm - show (IPragma {}) = "[externally defined pragma]" - show (ILog Nothing) = "%logging off" - show (ILog (Just (topic, lvl))) = "%logging " ++ case topic of + show (Elaboratable_Pragma {}) = "[externally defined pragma]" + show (Elaboratable_Logging Nothing) = "%logging off" + show (Elaboratable_Logging (Just (topic, lvl))) = "%logging " ++ case topic of [] => show lvl _ => concat (intersperse "." topic) ++ " " ++ show lvl - show (IBuiltin _ type name) = "%builtin " ++ show type ++ " " ++ show name + show (Elaboratable_Builtin_Declaration _ type name) = "%builtin " ++ show type ++ " " ++ show name export @@ -525,31 +525,31 @@ mkWithClause fc lhs ((rig, wval, prf) ::: wp :: wps) flags cls = let vfc = virtualiseFC fc arg = UN $ Basic "arg" in WithClause fc lhs rig wval prf flags - [mkWithClause fc (IApp vfc lhs $ IBindVar vfc arg) (wp ::: wps) flags cls] + [mkWithClause fc (Elaboratable_Apply vfc lhs $ Elaboratable_Bind_Name vfc arg) (wp ::: wps) flags cls] -- Extract the RawImp term from a FieldUpdate. export -getFieldUpdateTerm : IFieldUpdate' nm -> RawImp' nm -getFieldUpdateTerm (ISetField _ term) = term -getFieldUpdateTerm (ISetFieldApp _ term) = term +getFieldUpdateTerm : Elaboratable_Field_Update' nm -> RawImp' nm +getFieldUpdateTerm (Elaboratable_Set_Field _ term) = term +getFieldUpdateTerm (Elaboratable_Apply_To_Field _ term) = term export -getFieldUpdatePath : IFieldUpdate' nm -> List String -getFieldUpdatePath (ISetField path _) = path -getFieldUpdatePath (ISetFieldApp path _) = path +getFieldUpdatePath : Elaboratable_Field_Update' nm -> List String +getFieldUpdatePath (Elaboratable_Set_Field path _) = path +getFieldUpdatePath (Elaboratable_Apply_To_Field path _) = path export -mapFieldUpdateTerm : (RawImp' nm -> RawImp' nm) -> IFieldUpdate' nm -> IFieldUpdate' nm -mapFieldUpdateTerm f (ISetField x term) = ISetField x (f term) -mapFieldUpdateTerm f (ISetFieldApp x term) = ISetFieldApp x (f term) +mapFieldUpdateTerm : (RawImp' nm -> RawImp' nm) -> Elaboratable_Field_Update' nm -> Elaboratable_Field_Update' nm +mapFieldUpdateTerm f (Elaboratable_Set_Field x term) = Elaboratable_Set_Field x (f term) +mapFieldUpdateTerm f (Elaboratable_Apply_To_Field x term) = Elaboratable_Apply_To_Field x (f term) export -isIPrimVal : RawImp' nm -> Maybe Constant -isIPrimVal (IPrimVal _ c) = Just c -isIPrimVal _ = Nothing +is_primitive_value : RawImp' nm -> Maybe Constant +is_primitive_value (Elaboratable_Primitive_Value _ c) = Just c +is_primitive_value _ = Nothing -- REPL commands for TTImp interaction public export @@ -572,102 +572,102 @@ mapAltType _ u = u export lhsInCurrentNS : {auto c : Ref Ctxt Defs} -> NestedNames vars -> RawImp -> Core RawImp -lhsInCurrentNS nest (IApp loc f a) +lhsInCurrentNS nest (Elaboratable_Apply loc f a) = do f' <- lhsInCurrentNS nest f - pure (IApp loc f' a) -lhsInCurrentNS nest (IAutoApp loc f a) + pure (Elaboratable_Apply loc f' a) +lhsInCurrentNS nest (Elaboratable_Automatic_Apply loc f a) = do f' <- lhsInCurrentNS nest f - pure (IAutoApp loc f' a) -lhsInCurrentNS nest (INamedApp loc f n a) + pure (Elaboratable_Automatic_Apply loc f' a) +lhsInCurrentNS nest (Elaboratable_Named_Apply loc f n a) = do f' <- lhsInCurrentNS nest f - pure (INamedApp loc f' n a) -lhsInCurrentNS nest (IWithApp loc f a) + pure (Elaboratable_Named_Apply loc f' n a) +lhsInCurrentNS nest (Elaboratable_With_Apply loc f a) = do f' <- lhsInCurrentNS nest f - pure (IWithApp loc f' a) -lhsInCurrentNS nest tm@(IVar loc (NS {})) = pure tm -- leave explicit NS alone -lhsInCurrentNS nest (IVar loc n) + pure (Elaboratable_With_Apply loc f' a) +lhsInCurrentNS nest tm@(Elaboratable_Name loc (NS {})) = pure tm -- leave explicit NS alone +lhsInCurrentNS nest (Elaboratable_Name loc n) = case lookup n (names nest) of Nothing => do n' <- inCurrentNS n - pure (IVar loc n') + pure (Elaboratable_Name loc n') -- If it's one of the names in the current nested block, we'll -- be rewriting it during elaboration to be in the scope of the -- parent name. - Just _ => pure (IVar loc n) + Just _ => pure (Elaboratable_Name loc n) lhsInCurrentNS nest tm = pure tm export -findIBinds : RawImp' nm -> List String -findIBinds (IPi fc rig p mn aty retty) - = findIBinds aty ++ findIBinds retty -findIBinds (ILam fc rig p n aty sc) - = findIBinds aty ++ findIBinds sc -findIBinds (IApp fc fn av) - = findIBinds fn ++ findIBinds av -findIBinds (IAutoApp fc fn av) - = findIBinds fn ++ findIBinds av -findIBinds (INamedApp _ fn _ av) - = findIBinds fn ++ findIBinds av -findIBinds (IWithApp fc fn av) - = findIBinds fn ++ findIBinds av -findIBinds (IAs fc _ _ (UN (Basic n)) pat) - = n :: findIBinds pat -findIBinds (IAs fc _ _ n pat) - = findIBinds pat -findIBinds (IMustUnify fc r pat) - = findIBinds pat -findIBinds (IAlternative fc u alts) - = concatMap findIBinds alts -findIBinds (IDelayed fc _ ty) = findIBinds ty -findIBinds (IDelay fc tm) = findIBinds tm -findIBinds (IForce fc tm) = findIBinds tm -findIBinds (IQuote fc tm) = findIBinds tm -findIBinds (IUnquote fc tm) = findIBinds tm -findIBinds (IRunElab fc _ tm) = findIBinds tm -findIBinds (IBindHere _ _ tm) = findIBinds tm -findIBinds (IBindVar _ (UN (Basic n))) = [n] -findIBinds (IUpdate fc updates tm) - = findIBinds tm ++ concatMap (findIBinds . getFieldUpdateTerm) updates +find_names_to_bind : RawImp' nm -> List String +find_names_to_bind (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) + = find_names_to_bind aty ++ find_names_to_bind retty +find_names_to_bind (Elaboratable_Lambda fc rig p n aty sc) + = find_names_to_bind aty ++ find_names_to_bind sc +find_names_to_bind (Elaboratable_Apply fc fn av) + = find_names_to_bind fn ++ find_names_to_bind av +find_names_to_bind (Elaboratable_Automatic_Apply fc fn av) + = find_names_to_bind fn ++ find_names_to_bind av +find_names_to_bind (Elaboratable_Named_Apply _ fn _ av) + = find_names_to_bind fn ++ find_names_to_bind av +find_names_to_bind (Elaboratable_With_Apply fc fn av) + = find_names_to_bind fn ++ find_names_to_bind av +find_names_to_bind (Elaboratable_As_Pattern fc _ _ (UN (Basic n)) pat) + = n :: find_names_to_bind pat +find_names_to_bind (Elaboratable_As_Pattern fc _ _ n pat) + = find_names_to_bind pat +find_names_to_bind (Elaboratable_Must_Unify fc r pat) + = find_names_to_bind pat +find_names_to_bind (Elaboratable_Alternative fc u alts) + = concatMap find_names_to_bind alts +find_names_to_bind (Elaboratable_Delayed_Type fc _ ty) = find_names_to_bind ty +find_names_to_bind (Elaboratable_Delay fc tm) = find_names_to_bind tm +find_names_to_bind (Elaboratable_Force fc tm) = find_names_to_bind tm +find_names_to_bind (Elaboratable_Quote fc tm) = find_names_to_bind tm +find_names_to_bind (Elaboratable_Unquote fc tm) = find_names_to_bind tm +find_names_to_bind (Elaboratable_Run_Elaborator fc _ tm) = find_names_to_bind tm +find_names_to_bind (Elaboratable_Bind_Here _ _ tm) = find_names_to_bind tm +find_names_to_bind (Elaboratable_Bind_Name _ (UN (Basic n))) = [n] +find_names_to_bind (Elaboratable_Record_Update fc updates tm) + = find_names_to_bind tm ++ concatMap (find_names_to_bind . getFieldUpdateTerm) updates -- We've skipped lambda, case, let and local - rather than guess where the -- name should be bound, leave it to the programmer -findIBinds tm = [] +find_names_to_bind tm = [] export findImplicits : RawImp' nm -> List String -findImplicits (IPi fc rig p (Just (UN (Basic mn))) aty retty) +findImplicits (Elaboratable_Dependent_Function_Type fc rig p (Just (UN (Basic mn))) aty retty) = mn :: findImplicits aty ++ findImplicits retty -findImplicits (IPi fc rig p mn aty retty) +findImplicits (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) = findImplicits aty ++ findImplicits retty -findImplicits (ILam fc rig p n aty sc) +findImplicits (Elaboratable_Lambda fc rig p n aty sc) = findImplicits aty ++ findImplicits sc -findImplicits (IApp fc fn av) +findImplicits (Elaboratable_Apply fc fn av) = findImplicits fn ++ findImplicits av -findImplicits (IAutoApp _ fn av) +findImplicits (Elaboratable_Automatic_Apply _ fn av) = findImplicits fn ++ findImplicits av -findImplicits (INamedApp _ fn _ av) +findImplicits (Elaboratable_Named_Apply _ fn _ av) = findImplicits fn ++ findImplicits av -findImplicits (IWithApp fc fn av) +findImplicits (Elaboratable_With_Apply fc fn av) = findImplicits fn ++ findImplicits av -findImplicits (IAs fc _ _ n pat) +findImplicits (Elaboratable_As_Pattern fc _ _ n pat) = findImplicits pat -findImplicits (IMustUnify fc r pat) +findImplicits (Elaboratable_Must_Unify fc r pat) = findImplicits pat -findImplicits (IAlternative fc u alts) +findImplicits (Elaboratable_Alternative fc u alts) = concatMap findImplicits alts -findImplicits (IDelayed fc _ ty) = findImplicits ty -findImplicits (IDelay fc tm) = findImplicits tm -findImplicits (IForce fc tm) = findImplicits tm -findImplicits (IQuote fc tm) = findImplicits tm -findImplicits (IUnquote fc tm) = findImplicits tm -findImplicits (IRunElab fc _ tm) = findImplicits tm -findImplicits (IBindVar _ (UN (Basic n))) = [n] -findImplicits (IUpdate fc updates tm) +findImplicits (Elaboratable_Delayed_Type fc _ ty) = findImplicits ty +findImplicits (Elaboratable_Delay fc tm) = findImplicits tm +findImplicits (Elaboratable_Force fc tm) = findImplicits tm +findImplicits (Elaboratable_Quote fc tm) = findImplicits tm +findImplicits (Elaboratable_Unquote fc tm) = findImplicits tm +findImplicits (Elaboratable_Run_Elaborator fc _ tm) = findImplicits tm +findImplicits (Elaboratable_Bind_Name _ (UN (Basic n))) = [n] +findImplicits (Elaboratable_Record_Update fc updates tm) = findImplicits tm ++ concatMap (findImplicits . getFieldUpdateTerm) updates findImplicits tm = [] -- Update the lhs of a clause so that any implicits named in the type are -- bound as @-patterns (unless they're already explicitly bound or appear as --- IBindVar anywhere else in the pattern) so that they will be available on the +-- Elaboratable_Bind_Name anywhere else in the pattern) so that they will be available on the -- rhs export implicitsAs : {auto c : Ref Ctxt Defs} -> @@ -675,7 +675,7 @@ implicitsAs : {auto c : Ref Ctxt Defs} -> (vars : List Name) -> RawImp -> Core RawImp implicitsAs n defs ns tm - = do let implicits = findIBinds tm + = do let implicits = find_names_to_bind tm log "declare.def.lhs.implicits" 30 $ "Found implicits: " ++ show implicits setAs (map Just (ns ++ map (UN . Basic) implicits)) [] tm where @@ -685,25 +685,25 @@ implicitsAs n defs ns tm -- More precisely, implicit and explicit arguments are recorded separately, -- into `is` and `es` respectively. setAs : List (Maybe Name) -> List (Maybe Name) -> RawImp -> Core RawImp - setAs is es (IApp loc f a) + setAs is es (Elaboratable_Apply loc f a) = do f' <- setAs is (Nothing :: es) f - pure $ IApp loc f' a - setAs is es (IAutoApp loc f a) + pure $ Elaboratable_Apply loc f' a + setAs is es (Elaboratable_Automatic_Apply loc f a) = do f' <- setAs (Nothing :: is) es f - pure $ IAutoApp loc f' a - setAs is es (INamedApp loc f n a) + pure $ Elaboratable_Automatic_Apply loc f' a + setAs is es (Elaboratable_Named_Apply loc f n a) = do f' <- setAs (Just n :: is) (Just n :: es) f - pure $ INamedApp loc f' n a - setAs is es (IWithApp loc f a) + pure $ Elaboratable_Named_Apply loc f' n a + setAs is es (Elaboratable_With_Apply loc f a) = do f' <- setAs is es f - pure $ IWithApp loc f' a - setAs is es (IVar loc nm) + pure $ Elaboratable_With_Apply loc f' a + setAs is es (Elaboratable_Name loc nm) -- #834 Use the (already) resolved name rather than the local one = case !(lookupTyExact (Resolved n) (gamma defs)) of Nothing => do log "declare.def.lhs.implicits" 30 $ "Could not find variable " ++ show n - pure $ IVar loc nm + pure $ Elaboratable_Name loc nm Just ty => do ty' <- nf defs Env.empty ty implicits <- findImps is es ns ty' @@ -711,7 +711,7 @@ implicitsAs n defs ns tm "\n In the type of " ++ show n ++ ": " ++ show ty ++ "\n Using locals: " ++ show ns ++ "\n Found implicits: " ++ show implicits - pure $ impAs (virtualiseFC loc) implicits (IVar loc nm) + pure $ impAs (virtualiseFC loc) implicits (Elaboratable_Name loc nm) where -- If there's an @{c} in the list of given implicits, that's the next -- autoimplicit, so don't rewrite the LHS and update the list of given @@ -776,17 +776,17 @@ implicitsAs n defs ns tm impAs loc' [] tm = tm impAs loc' ((nm@(UN (Basic _)), AutoImplicit) :: ns) tm = impAs loc' ns $ - INamedApp loc' tm nm (IBindVar loc' nm) + Elaboratable_Named_Apply loc' tm nm (Elaboratable_Bind_Name loc' nm) impAs loc' ((n, Implicit) :: ns) tm = impAs loc' ns $ - INamedApp loc' tm n - (IAs loc' EmptyFC UseLeft n (Implicit loc' True)) + Elaboratable_Named_Apply loc' tm n + (Elaboratable_As_Pattern loc' EmptyFC UseLeft n (Implicit loc' True)) impAs loc' ((n, DefImplicit t) :: ns) tm = impAs loc' ns $ - INamedApp loc' tm n - (IAs loc' EmptyFC UseLeft n (Implicit loc' True)) + Elaboratable_Named_Apply loc' tm n + (Elaboratable_As_Pattern loc' EmptyFC UseLeft n (Implicit loc' True)) impAs loc' (_ :: ns) tm = impAs loc' ns tm setAs is es tm = pure tm @@ -802,7 +802,7 @@ definedInBlock ns decls = getName : ImpTy -> Name getName = (.tyName.val) - getFieldName : IField -> Name + getFieldName : Elaboratable_Field -> Name getFieldName f = f.name.val expandNS : Namespace -> Name -> Name @@ -814,15 +814,15 @@ definedInBlock ns decls = _ => n defName : Namespace -> SortedSet Name -> ImpDecl -> SortedSet Name - defName ns acc (IClaim c) = insert (expandNS ns (getName c.val.type)) acc - defName ns acc (IDef _ nm _) = insert (expandNS ns nm) acc - defName ns acc (IData _ _ _ (MkImpData _ n _ _ cons)) + defName ns acc (Elaboratable_Claim c) = insert (expandNS ns (getName c.val.type)) acc + defName ns acc (Elaboratable_Definition _ nm _) = insert (expandNS ns nm) acc + defName ns acc (Elaboratable_Data_Declaration _ _ _ (MkImpData _ n _ _ cons)) = foldl (flip insert) acc $ expandNS ns n :: map (expandNS ns . getName) cons - defName ns acc (IData _ _ _ (MkImpLater _ n _)) = insert (expandNS ns n) acc - defName ns acc (IParameters _ _ pds) = foldl (defName ns) acc pds - defName ns acc (IFail _ _ nds) = foldl (defName ns) acc nds - defName ns acc (INamespace _ n nds) = foldl (defName (ns <.> n)) acc nds - defName ns acc (IRecord _ fldns _ _ rec) + defName ns acc (Elaboratable_Data_Declaration _ _ _ (MkImpLater _ n _)) = insert (expandNS ns n) acc + defName ns acc (Elaboratable_Parameter_Block _ _ pds) = foldl (defName ns) acc pds + defName ns acc (Elaboratable_Expected_Failure _ _ nds) = foldl (defName ns) acc nds + defName ns acc (Elaboratable_Namespace_Block _ n nds) = foldl (defName (ns <.> n)) acc nds + defName ns acc (Elaboratable_Record_Declaration _ fldns _ _ rec) = foldl (flip insert) acc $ expandNS ns rec.val.body.name.val :: all where fldns' : Namespace @@ -848,72 +848,72 @@ definedInBlock ns decls = all : List Name all = expandNS ns rec.val.header.name.val :: map (expandNS fldns') (fnsRF ++ fnsUN) - defName ns acc (IPragma _ pns _) = foldl (flip insert) acc $ map (expandNS ns) pns + defName ns acc (Elaboratable_Pragma _ pns _) = foldl (flip insert) acc $ map (expandNS ns) pns defName _ acc _ = acc export -isIVar : RawImp' nm -> Maybe (FC, nm) -isIVar (IVar fc v) = Just (fc, v) -isIVar _ = Nothing +is_elaboratable_name : RawImp' nm -> Maybe (FC, nm) +is_elaboratable_name (Elaboratable_Name fc v) = Just (fc, v) +is_elaboratable_name _ = Nothing export -isIBindVar : RawImp' nm -> Maybe (FC, Name) -isIBindVar (IBindVar fc v) = Just (fc, v) -isIBindVar _ = Nothing +is_elaboratable_bound_name : RawImp' nm -> Maybe (FC, Name) +is_elaboratable_bound_name (Elaboratable_Bind_Name fc v) = Just (fc, v) +is_elaboratable_bound_name _ = Nothing export getFC : RawImp' nm -> FC -getFC (IVar x _) = x -getFC (IPi x _ _ _ _ _) = x -getFC (ILam x _ _ _ _ _) = x -getFC (ILet x _ _ _ _ _ _) = x -getFC (ICase x _ _ _ _) = x -getFC (ILocal x _ _) = x -getFC (ICaseLocal x _ _ _ _) = x -getFC (IUpdate x _ _) = x -getFC (IApp x _ _) = x -getFC (INamedApp x _ _ _) = x -getFC (IAutoApp x _ _) = x -getFC (IWithApp x _ _) = x -getFC (ISearch x _) = x -getFC (IAlternative x _ _) = x -getFC (IRewrite x _ _) = x -getFC (ICoerced x _) = x -getFC (IPrimVal x _) = x -getFC (IHole x _) = x -getFC (IUnifyLog x _ _) = x -getFC (IType x) = x -getFC (IBindVar x _) = x -getFC (IBindHere x _ _) = x -getFC (IMustUnify x _ _) = x -getFC (IDelayed x _ _) = x -getFC (IDelay x _) = x -getFC (IForce x _) = x -getFC (IQuote x _) = x -getFC (IQuoteName x _) = x -getFC (IQuoteDecl x _) = x -getFC (IUnquote x _) = x -getFC (IRunElab x _ _) = x -getFC (IAs x _ _ _ _) = x +getFC (Elaboratable_Name x _) = x +getFC (Elaboratable_Dependent_Function_Type x _ _ _ _ _) = x +getFC (Elaboratable_Lambda x _ _ _ _ _) = x +getFC (Elaboratable_Binding x _ _ _ _ _ _) = x +getFC (Elaboratable_Case x _ _ _ _) = x +getFC (Elaboratable_Local_Definitions x _ _) = x +getFC (Elaboratable_Case_Local_Definition x _ _ _ _) = x +getFC (Elaboratable_Record_Update x _ _) = x +getFC (Elaboratable_Apply x _ _) = x +getFC (Elaboratable_Named_Apply x _ _ _) = x +getFC (Elaboratable_Automatic_Apply x _ _) = x +getFC (Elaboratable_With_Apply x _ _) = x +getFC (Elaboratable_Search x _) = x +getFC (Elaboratable_Alternative x _ _) = x +getFC (Elaboratable_Rewrite x _ _) = x +getFC (Elaboratable_Coerced x _) = x +getFC (Elaboratable_Primitive_Value x _) = x +getFC (Elaboratable_Hole x _) = x +getFC (Elaboratable_Unification_Log x _ _) = x +getFC (Elaboratable_Type_Universe x) = x +getFC (Elaboratable_Bind_Name x _) = x +getFC (Elaboratable_Bind_Here x _ _) = x +getFC (Elaboratable_Must_Unify x _ _) = x +getFC (Elaboratable_Delayed_Type x _ _) = x +getFC (Elaboratable_Delay x _) = x +getFC (Elaboratable_Force x _) = x +getFC (Elaboratable_Quote x _) = x +getFC (Elaboratable_Quote_Name x _) = x +getFC (Elaboratable_Quote_Declarations x _) = x +getFC (Elaboratable_Unquote x _) = x +getFC (Elaboratable_Run_Elaborator x _ _) = x +getFC (Elaboratable_As_Pattern x _ _ _ _) = x getFC (Implicit x _) = x -getFC (IWithUnambigNames x _ _) = x +getFC (Elaboratable_With_Unambiguous_Names x _ _) = x namespace ImpDecl public export getFC : ImpDecl' nm -> FC - getFC (IClaim c) = c.fc - getFC (IData fc _ _ _) = fc - getFC (IDef fc _ _) = fc - getFC (IParameters fc _ _) = fc - getFC (IRecord fc _ _ _ _) = fc - getFC (IFail fc _ _) = fc - getFC (INamespace fc _ _) = fc - getFC (ITransform fc _ _ _) = fc - getFC (IRunElabDecl fc _) = fc - getFC (IPragma fc _ _) = fc - getFC (ILog _) = EmptyFC - getFC (IBuiltin fc _ _) = fc + getFC (Elaboratable_Claim c) = c.fc + getFC (Elaboratable_Data_Declaration fc _ _ _) = fc + getFC (Elaboratable_Definition fc _ _) = fc + getFC (Elaboratable_Parameter_Block fc _ _) = fc + getFC (Elaboratable_Record_Declaration fc _ _ _ _) = fc + getFC (Elaboratable_Expected_Failure fc _ _) = fc + getFC (Elaboratable_Namespace_Block fc _ _) = fc + getFC (Elaboratable_Transformation fc _ _ _) = fc + getFC (Elaboratable_Run_Elaborator_Declaration fc _) = fc + getFC (Elaboratable_Pragma fc _ _) = fc + getFC (Elaboratable_Logging _) = EmptyFC + getFC (Elaboratable_Builtin_Declaration fc _ _) = fc public export data Arg' nm @@ -927,8 +927,8 @@ Arg : Type Arg = Arg' Name public export -IArg : Type -IArg = Arg' KindedName +Kinded_Elaboratable_Argument : Type +Kinded_Elaboratable_Argument = Arg' KindedName export isExplicit : Arg' nm -> Maybe (FC, RawImp' nm) @@ -936,10 +936,10 @@ isExplicit (Explicit fc t) = Just (fc, t) isExplicit _ = Nothing export -unIArg : Arg' nm -> RawImp' nm -unIArg (Explicit _ t) = t -unIArg (Auto _ t) = t -unIArg (Named _ _ t) = t +elaboratable_argument_term : Arg' nm -> RawImp' nm +elaboratable_argument_term (Explicit _ t) = t +elaboratable_argument_term (Auto _ t) = t +elaboratable_argument_term (Named _ _ t) = t export covering @@ -950,18 +950,18 @@ Show nm => Show (Arg' nm) where export getFnArgs : RawImp' nm -> List (Arg' nm) -> (RawImp' nm, List (Arg' nm)) -getFnArgs (IApp fc f arg) args = getFnArgs f (Explicit fc arg :: args) -getFnArgs (INamedApp fc f n arg) args = getFnArgs f (Named fc n arg :: args) -getFnArgs (IAutoApp fc f arg) args = getFnArgs f (Auto fc arg :: args) +getFnArgs (Elaboratable_Apply fc f arg) args = getFnArgs f (Explicit fc arg :: args) +getFnArgs (Elaboratable_Named_Apply fc f n arg) args = getFnArgs f (Named fc n arg :: args) +getFnArgs (Elaboratable_Automatic_Apply fc f arg) args = getFnArgs f (Auto fc arg :: args) getFnArgs tm args = (tm, args) -- TODO: merge these definitions namespace Arg export apply : RawImp' nm -> List (Arg' nm) -> RawImp' nm - apply f (Explicit fc a :: args) = apply (IApp fc f a) args - apply f (Auto fc a :: args) = apply (IAutoApp fc f a) args - apply f (Named fc n a :: args) = apply (INamedApp fc f n a) args + apply f (Explicit fc a :: args) = apply (Elaboratable_Apply fc f a) args + apply f (Auto fc a :: args) = apply (Elaboratable_Automatic_Apply fc f a) args + apply f (Named fc n a :: args) = apply (Elaboratable_Named_Apply fc f n a) args apply f [] = f export @@ -969,7 +969,7 @@ apply : RawImp' nm -> List (RawImp' nm) -> RawImp' nm apply f [] = f apply f (x :: xs) = let fFC = getFC f in - apply (IApp (fromMaybe fFC (mergeFC fFC (getFC x))) f x) xs + apply (Elaboratable_Apply (fromMaybe fFC (mergeFC fFC (getFC x))) f x) xs export gapply : RawImp' nm -> List (Maybe Name, RawImp' nm) -> RawImp' nm @@ -977,18 +977,18 @@ gapply f [] = f gapply f (x :: xs) = gapply (uncurry (app f) x) xs where app : RawImp' nm -> Maybe Name -> RawImp' nm -> RawImp' nm - app f Nothing x = IApp (getFC f) f x - app f (Just nm) x = INamedApp (getFC f) f nm x + app f Nothing x = Elaboratable_Apply (getFC f) f x + app f (Just nm) x = Elaboratable_Named_Apply (getFC f) f nm x export getFn : RawImp' nm -> RawImp' nm -getFn (IApp _ f _) = getFn f -getFn (IWithApp _ f _) = getFn f -getFn (INamedApp _ f _ _) = getFn f -getFn (IAutoApp _ f _) = getFn f -getFn (IAs _ _ _ _ f) = getFn f -getFn (IMustUnify _ _ f) = getFn f +getFn (Elaboratable_Apply _ f _) = getFn f +getFn (Elaboratable_With_Apply _ f _) = getFn f +getFn (Elaboratable_Named_Apply _ f _ _) = getFn f +getFn (Elaboratable_Automatic_Apply _ f _) = getFn f +getFn (Elaboratable_As_Pattern _ _ _ _ f) = getFn f +getFn (Elaboratable_Must_Unify _ _ f) = getFn f getFn f = f -- Log message with a RawImp diff --git a/TTImp/TTImp/Functor.idr b/TTImp/TTImp/Functor.idr index 8baaf30baf..978fbab965 100644 --- a/TTImp/TTImp/Functor.idr +++ b/TTImp/TTImp/Functor.idr @@ -10,73 +10,73 @@ mutual export Functor RawImp' where - map f (IVar fc nm) = IVar fc (f nm) - map f (IPi fc rig info nm a sc) - = IPi fc rig (map (map f) info) nm (map f a) (map f sc) - map f (ILam fc rig info nm a sc) - = ILam fc rig (map (map f) info) nm (map f a) (map f sc) - map f (ILet fc lhsFC rig nm ty val sc) - = ILet fc lhsFC rig nm (map f ty) (map f val) (map f sc) - map f (ICase fc opts sc ty cls) - = ICase fc (map (map f) opts) (map f sc) (map f ty) (map (map f) cls) - map f (ILocal fc ds sc) - = ILocal fc (map (map f) ds) (map f sc) - map f (ICaseLocal fc userN intN args sc) - = ICaseLocal fc userN intN args (map f sc) - map f (IUpdate fc upds rec) - = IUpdate fc (map (map f) upds) (map f rec) - map f (IApp fc fn t) - = IApp fc (map f fn) (map f t) - map f (IAutoApp fc fn t) - = IAutoApp fc (map f fn) (map f t) - map f (INamedApp fc fn nm t) - = INamedApp fc (map f fn) nm (map f t) - map f (IWithApp fc fn t) - = IWithApp fc (map f fn) (map f t) - map f (ISearch fc n) - = ISearch fc n - map f (IAlternative fc alt ts) - = IAlternative fc (map f alt) (map (map f) ts) - map f (IRewrite fc e t) - = IRewrite fc (map f e) (map f t) - map f (ICoerced fc e) - = ICoerced fc (map f e) - map f (IBindHere fc bd t) - = IBindHere fc bd (map f t) - map f (IBindVar fc str) - = IBindVar fc str - map f (IAs fc nmFC side nm t) - = IAs fc nmFC side nm (map f t) - map f (IMustUnify fc reason t) - = IMustUnify fc reason (map f t) - map f (IDelayed fc reason t) - = IDelayed fc reason (map f t) - map f (IDelay fc t) - = IDelay fc (map f t) - map f (IForce fc t) - = IForce fc (map f t) - map f (IQuote fc t) - = IQuote fc (map f t) - map f (IQuoteName fc nm) - = IQuoteName fc nm - map f (IQuoteDecl fc ds) - = IQuoteDecl fc (map (map f) ds) - map f (IUnquote fc t) - = IUnquote fc (map f t) - map f (IRunElab fc re t) - = IRunElab fc re (map f t) - map f (IPrimVal fc c) - = IPrimVal fc c - map f (IType fc) - = IType fc - map f (IHole fc str) - = IHole fc str - map f (IUnifyLog fc lvl t) - = IUnifyLog fc lvl (map f t) + map f (Elaboratable_Name fc nm) = Elaboratable_Name fc (f nm) + map f (Elaboratable_Dependent_Function_Type fc rig info nm a sc) + = Elaboratable_Dependent_Function_Type fc rig (map (map f) info) nm (map f a) (map f sc) + map f (Elaboratable_Lambda fc rig info nm a sc) + = Elaboratable_Lambda fc rig (map (map f) info) nm (map f a) (map f sc) + map f (Elaboratable_Binding fc lhsFC rig nm ty val sc) + = Elaboratable_Binding fc lhsFC rig nm (map f ty) (map f val) (map f sc) + map f (Elaboratable_Case fc opts sc ty cls) + = Elaboratable_Case fc (map (map f) opts) (map f sc) (map f ty) (map (map f) cls) + map f (Elaboratable_Local_Definitions fc ds sc) + = Elaboratable_Local_Definitions fc (map (map f) ds) (map f sc) + map f (Elaboratable_Case_Local_Definition fc userN intN args sc) + = Elaboratable_Case_Local_Definition fc userN intN args (map f sc) + map f (Elaboratable_Record_Update fc upds rec) + = Elaboratable_Record_Update fc (map (map f) upds) (map f rec) + map f (Elaboratable_Apply fc fn t) + = Elaboratable_Apply fc (map f fn) (map f t) + map f (Elaboratable_Automatic_Apply fc fn t) + = Elaboratable_Automatic_Apply fc (map f fn) (map f t) + map f (Elaboratable_Named_Apply fc fn nm t) + = Elaboratable_Named_Apply fc (map f fn) nm (map f t) + map f (Elaboratable_With_Apply fc fn t) + = Elaboratable_With_Apply fc (map f fn) (map f t) + map f (Elaboratable_Search fc n) + = Elaboratable_Search fc n + map f (Elaboratable_Alternative fc alt ts) + = Elaboratable_Alternative fc (map f alt) (map (map f) ts) + map f (Elaboratable_Rewrite fc e t) + = Elaboratable_Rewrite fc (map f e) (map f t) + map f (Elaboratable_Coerced fc e) + = Elaboratable_Coerced fc (map f e) + map f (Elaboratable_Bind_Here fc bd t) + = Elaboratable_Bind_Here fc bd (map f t) + map f (Elaboratable_Bind_Name fc str) + = Elaboratable_Bind_Name fc str + map f (Elaboratable_As_Pattern fc nmFC side nm t) + = Elaboratable_As_Pattern fc nmFC side nm (map f t) + map f (Elaboratable_Must_Unify fc reason t) + = Elaboratable_Must_Unify fc reason (map f t) + map f (Elaboratable_Delayed_Type fc reason t) + = Elaboratable_Delayed_Type fc reason (map f t) + map f (Elaboratable_Delay fc t) + = Elaboratable_Delay fc (map f t) + map f (Elaboratable_Force fc t) + = Elaboratable_Force fc (map f t) + map f (Elaboratable_Quote fc t) + = Elaboratable_Quote fc (map f t) + map f (Elaboratable_Quote_Name fc nm) + = Elaboratable_Quote_Name fc nm + map f (Elaboratable_Quote_Declarations fc ds) + = Elaboratable_Quote_Declarations fc (map (map f) ds) + map f (Elaboratable_Unquote fc t) + = Elaboratable_Unquote fc (map f t) + map f (Elaboratable_Run_Elaborator fc re t) + = Elaboratable_Run_Elaborator fc re (map f t) + map f (Elaboratable_Primitive_Value fc c) + = Elaboratable_Primitive_Value fc c + map f (Elaboratable_Type_Universe fc) + = Elaboratable_Type_Universe fc + map f (Elaboratable_Hole fc str) + = Elaboratable_Hole fc str + map f (Elaboratable_Unification_Log fc lvl t) + = Elaboratable_Unification_Log fc lvl (map f t) map f (Implicit fc b) = Implicit fc b - map f (IWithUnambigNames fc ns t) - = IWithUnambigNames fc ns (map f t) + map f (Elaboratable_With_Unambiguous_Names fc ns t) + = Elaboratable_With_Unambiguous_Names fc ns (map f t) export Functor ImpClause' where @@ -88,33 +88,33 @@ mutual = ImpossibleClause fc (map f lhs) export - Functor IClaimData where - map f (MkIClaimData rig vis opts ty) - = MkIClaimData rig vis (map (map f) opts) (map (map f) ty) + Functor Elaboratable_Claim_Data where + map f (Make_Elaboratable_Claim_Data rig vis opts ty) + = Make_Elaboratable_Claim_Data rig vis (map (map f) opts) (map (map f) ty) export Functor ImpDecl' where - map f (IClaim c) - = IClaim (map (map f) c) - map f (IData fc vis mbtot dt) - = IData fc vis mbtot (map f dt) - map f (IDef fc nm cls) - = IDef fc nm (map (map f) cls) - map f (IParameters fc ps ds) - = IParameters fc (map (map (map (map f))) ps) (map (map f) ds) - map f (IRecord fc cs vis mbtot rec) - = IRecord fc cs vis mbtot (map (map f) rec) - map f (IFail fc msg ds) - = IFail fc msg (map (map f) ds) - map f (INamespace fc ns ds) - = INamespace fc ns (map (map f) ds) - map f (ITransform fc n lhs rhs) - = ITransform fc n (map f lhs) (map f rhs) - map f (IRunElabDecl fc t) - = IRunElabDecl fc (map f t) - map f (IPragma fc xs k) = IPragma fc xs k - map f (ILog x) = ILog x - map f (IBuiltin fc ty n) = IBuiltin fc ty n + map f (Elaboratable_Claim c) + = Elaboratable_Claim (map (map f) c) + map f (Elaboratable_Data_Declaration fc vis mbtot dt) + = Elaboratable_Data_Declaration fc vis mbtot (map f dt) + map f (Elaboratable_Definition fc nm cls) + = Elaboratable_Definition fc nm (map (map f) cls) + map f (Elaboratable_Parameter_Block fc ps ds) + = Elaboratable_Parameter_Block fc (map (map (map (map f))) ps) (map (map f) ds) + map f (Elaboratable_Record_Declaration fc cs vis mbtot rec) + = Elaboratable_Record_Declaration fc cs vis mbtot (map (map f) rec) + map f (Elaboratable_Expected_Failure fc msg ds) + = Elaboratable_Expected_Failure fc msg (map (map f) ds) + map f (Elaboratable_Namespace_Block fc ns ds) + = Elaboratable_Namespace_Block fc ns (map (map f) ds) + map f (Elaboratable_Transformation fc n lhs rhs) + = Elaboratable_Transformation fc n (map f lhs) (map f rhs) + map f (Elaboratable_Run_Elaborator_Declaration fc t) + = Elaboratable_Run_Elaborator_Declaration fc (map f t) + map f (Elaboratable_Pragma fc xs k) = Elaboratable_Pragma fc xs k + map f (Elaboratable_Logging x) = Elaboratable_Logging x + map f (Elaboratable_Builtin_Declaration fc ty n) = Elaboratable_Builtin_Declaration fc ty n export Functor FnOpt' where @@ -147,9 +147,9 @@ mutual (map (map (map (map (map f)))) body) export - Functor IFieldUpdate' where - map f (ISetField path t) = ISetField path (map f t) - map f (ISetFieldApp path t) = ISetFieldApp path (map f t) + Functor Elaboratable_Field_Update' where + map f (Elaboratable_Set_Field path t) = Elaboratable_Set_Field path (map f t) + map f (Elaboratable_Apply_To_Field path t) = Elaboratable_Apply_To_Field path (map f t) export Functor AltType' where diff --git a/TTImp/TTImp/TTC.idr b/TTImp/TTImp/TTC.idr index 439fef12ca..45af76fa54 100644 --- a/TTImp/TTImp/TTC.idr +++ b/TTImp/TTImp/TTC.idr @@ -16,191 +16,191 @@ import Libraries.Data.WithDefault mutual export TTC RawImp where - toBuf (IVar fc n) = do tag 0; toBuf fc; toBuf n - toBuf (IPi fc r p n argTy retTy) + toBuf (Elaboratable_Name fc n) = do tag 0; toBuf fc; toBuf n + toBuf (Elaboratable_Dependent_Function_Type fc r p n argTy retTy) = do tag 1; toBuf fc; toBuf r; toBuf p; toBuf n toBuf argTy; toBuf retTy - toBuf (ILam fc r p n argTy scope) + toBuf (Elaboratable_Lambda fc r p n argTy scope) = do tag 2; toBuf fc; toBuf r; toBuf p; toBuf n; toBuf argTy; toBuf scope - toBuf (ILet fc lhsFC r n nTy nVal scope) + toBuf (Elaboratable_Binding fc lhsFC r n nTy nVal scope) = do tag 3; toBuf fc; toBuf lhsFC; toBuf r; toBuf n; toBuf nTy; toBuf nVal; toBuf scope - toBuf (ICase fc opts y ty xs) + toBuf (Elaboratable_Case fc opts y ty xs) = do tag 4; toBuf fc; toBuf opts; toBuf y; toBuf ty; toBuf xs - toBuf (ILocal fc xs sc) + toBuf (Elaboratable_Local_Definitions fc xs sc) = do tag 5; toBuf fc; toBuf xs; toBuf sc - toBuf (ICaseLocal fc _ _ _ sc) + toBuf (Elaboratable_Case_Local_Definition fc _ _ _ sc) = toBuf sc - toBuf (IUpdate fc fs rec) + toBuf (Elaboratable_Record_Update fc fs rec) = do tag 6; toBuf fc; toBuf fs; toBuf rec - toBuf (IApp fc fn arg) + toBuf (Elaboratable_Apply fc fn arg) = do tag 7; toBuf fc; toBuf fn; toBuf arg - toBuf (INamedApp fc fn y arg) + toBuf (Elaboratable_Named_Apply fc fn y arg) = do tag 8; toBuf fc; toBuf fn; toBuf y; toBuf arg - toBuf (IWithApp fc fn arg) + toBuf (Elaboratable_With_Apply fc fn arg) = do tag 9; toBuf fc; toBuf fn; toBuf arg - toBuf (ISearch fc depth) + toBuf (Elaboratable_Search fc depth) = do tag 10; toBuf fc; toBuf depth - toBuf (IAlternative fc y xs) + toBuf (Elaboratable_Alternative fc y xs) = do tag 11; toBuf fc; toBuf y; toBuf xs - toBuf (IRewrite fc x y) + toBuf (Elaboratable_Rewrite fc x y) = do tag 12; toBuf fc; toBuf x; toBuf y - toBuf (ICoerced fc y) + toBuf (Elaboratable_Coerced fc y) = do tag 13; toBuf fc; toBuf y - toBuf (IBindHere fc m y) + toBuf (Elaboratable_Bind_Here fc m y) = do tag 14; toBuf fc; toBuf m; toBuf y - toBuf (IBindVar fc y) + toBuf (Elaboratable_Bind_Name fc y) = do tag 15; toBuf fc; toBuf y - toBuf (IAs fc nameFC s y pattern) + toBuf (Elaboratable_As_Pattern fc nameFC s y pattern) = do tag 16; toBuf fc; toBuf nameFC; toBuf s; toBuf y; toBuf pattern - toBuf (IMustUnify fc r pattern) + toBuf (Elaboratable_Must_Unify fc r pattern) -- No need to record 'r', it's for type errors only = do tag 17; toBuf fc; toBuf pattern - toBuf (IDelayed fc r y) + toBuf (Elaboratable_Delayed_Type fc r y) = do tag 18; toBuf fc; toBuf r; toBuf y - toBuf (IDelay fc t) + toBuf (Elaboratable_Delay fc t) = do tag 19; toBuf fc; toBuf t - toBuf (IForce fc t) + toBuf (Elaboratable_Force fc t) = do tag 20; toBuf fc; toBuf t - toBuf (IQuote fc t) + toBuf (Elaboratable_Quote fc t) = do tag 21; toBuf fc; toBuf t - toBuf (IQuoteName fc t) + toBuf (Elaboratable_Quote_Name fc t) = do tag 22; toBuf fc; toBuf t - toBuf (IQuoteDecl fc t) + toBuf (Elaboratable_Quote_Declarations fc t) = do tag 23; toBuf fc; toBuf t - toBuf (IUnquote fc t) + toBuf (Elaboratable_Unquote fc t) = do tag 24; toBuf fc; toBuf t - toBuf (IRunElab fc re t) + toBuf (Elaboratable_Run_Elaborator fc re t) = do tag 25; toBuf fc; toBuf re; toBuf t - toBuf (IPrimVal fc y) + toBuf (Elaboratable_Primitive_Value fc y) = do tag 26; toBuf fc; toBuf y - toBuf (IType fc) + toBuf (Elaboratable_Type_Universe fc) = do tag 27; toBuf fc - toBuf (IHole fc y) + toBuf (Elaboratable_Hole fc y) = do tag 28; toBuf fc; toBuf y - toBuf (IUnifyLog fc lvl x) = toBuf x + toBuf (Elaboratable_Unification_Log fc lvl x) = toBuf x toBuf (Implicit fc i) = do tag 29; toBuf fc; toBuf i - toBuf (IWithUnambigNames fc ns rhs) + toBuf (Elaboratable_With_Unambiguous_Names fc ns rhs) = do tag 30; toBuf fc; toBuf ns; toBuf rhs - toBuf (IAutoApp fc fn arg) + toBuf (Elaboratable_Automatic_Apply fc fn arg) = do tag 31; toBuf fc; toBuf fn; toBuf arg fromBuf = case !getTag of 0 => do fc <- fromBuf; n <- fromBuf; - pure (IVar fc n) + pure (Elaboratable_Name fc n) 1 => do fc <- fromBuf; r <- fromBuf; p <- fromBuf; n <- fromBuf argTy <- fromBuf; retTy <- fromBuf - pure (IPi fc r p n argTy retTy) + pure (Elaboratable_Dependent_Function_Type fc r p n argTy retTy) 2 => do fc <- fromBuf; r <- fromBuf; p <- fromBuf; n <- fromBuf argTy <- fromBuf; scope <- fromBuf - pure (ILam fc r p n argTy scope) + pure (Elaboratable_Lambda fc r p n argTy scope) 3 => do fc <- fromBuf; lhsFC <- fromBuf; r <- fromBuf; n <- fromBuf nTy <- fromBuf; nVal <- fromBuf scope <- fromBuf - pure (ILet fc lhsFC r n nTy nVal scope) + pure (Elaboratable_Binding fc lhsFC r n nTy nVal scope) 4 => do fc <- fromBuf; opts <- fromBuf; y <- fromBuf; ty <- fromBuf; xs <- fromBuf - pure (ICase fc opts y ty xs) + pure (Elaboratable_Case fc opts y ty xs) 5 => do fc <- fromBuf; xs <- fromBuf; sc <- fromBuf - pure (ILocal fc xs sc) + pure (Elaboratable_Local_Definitions fc xs sc) 6 => do fc <- fromBuf; fs <- fromBuf rec <- fromBuf - pure (IUpdate fc fs rec) + pure (Elaboratable_Record_Update fc fs rec) 7 => do fc <- fromBuf; fn <- fromBuf arg <- fromBuf - pure (IApp fc fn arg) + pure (Elaboratable_Apply fc fn arg) 8 => do fc <- fromBuf; fn <- fromBuf y <- fromBuf; arg <- fromBuf - pure (INamedApp fc fn y arg) + pure (Elaboratable_Named_Apply fc fn y arg) 9 => do fc <- fromBuf; fn <- fromBuf arg <- fromBuf - pure (IWithApp fc fn arg) + pure (Elaboratable_With_Apply fc fn arg) 10 => do fc <- fromBuf; depth <- fromBuf - pure (ISearch fc depth) + pure (Elaboratable_Search fc depth) 11 => do fc <- fromBuf; y <- fromBuf xs <- fromBuf - pure (IAlternative fc y xs) + pure (Elaboratable_Alternative fc y xs) 12 => do fc <- fromBuf; x <- fromBuf; y <- fromBuf - pure (IRewrite fc x y) + pure (Elaboratable_Rewrite fc x y) 13 => do fc <- fromBuf; y <- fromBuf - pure (ICoerced fc y) + pure (Elaboratable_Coerced fc y) 14 => do fc <- fromBuf; m <- fromBuf; y <- fromBuf - pure (IBindHere fc m y) + pure (Elaboratable_Bind_Here fc m y) 15 => do fc <- fromBuf; y <- fromBuf - pure (IBindVar fc y) + pure (Elaboratable_Bind_Name fc y) 16 => do fc <- fromBuf; nameFC <- fromBuf side <- fromBuf; y <- fromBuf; pattern <- fromBuf - pure (IAs fc nameFC side y pattern) + pure (Elaboratable_As_Pattern fc nameFC side y pattern) 17 => do fc <- fromBuf pattern <- fromBuf - pure (IMustUnify fc UnknownDot pattern) + pure (Elaboratable_Must_Unify fc UnknownDot pattern) 18 => do fc <- fromBuf; r <- fromBuf y <- fromBuf - pure (IDelayed fc r y) + pure (Elaboratable_Delayed_Type fc r y) 19 => do fc <- fromBuf; y <- fromBuf - pure (IDelay fc y) + pure (Elaboratable_Delay fc y) 20 => do fc <- fromBuf; y <- fromBuf - pure (IForce fc y) + pure (Elaboratable_Force fc y) 21 => do fc <- fromBuf; y <- fromBuf - pure (IQuote fc y) + pure (Elaboratable_Quote fc y) 22 => do fc <- fromBuf; y <- fromBuf - pure (IQuoteName fc y) + pure (Elaboratable_Quote_Name fc y) 23 => do fc <- fromBuf; y <- fromBuf - pure (IQuoteDecl fc y) + pure (Elaboratable_Quote_Declarations fc y) 24 => do fc <- fromBuf; y <- fromBuf - pure (IUnquote fc y) + pure (Elaboratable_Unquote fc y) 25 => do fc <- fromBuf; re <- fromBuf; y <- fromBuf - pure (IRunElab fc re y) + pure (Elaboratable_Run_Elaborator fc re y) 26 => do fc <- fromBuf; y <- fromBuf - pure (IPrimVal fc y) + pure (Elaboratable_Primitive_Value fc y) 27 => do fc <- fromBuf - pure (IType fc) + pure (Elaboratable_Type_Universe fc) 28 => do fc <- fromBuf; y <- fromBuf - pure (IHole fc y) + pure (Elaboratable_Hole fc y) 29 => do fc <- fromBuf i <- fromBuf pure (Implicit fc i) 30 => do fc <- fromBuf ns <- fromBuf rhs <- fromBuf - pure (IWithUnambigNames fc ns rhs) + pure (Elaboratable_With_Unambiguous_Names fc ns rhs) 31 => do fc <- fromBuf; fn <- fromBuf arg <- fromBuf - pure (IAutoApp fc fn arg) + pure (Elaboratable_Automatic_Apply fc fn arg) _ => corrupt "RawImp" export - TTC IFieldUpdate where - toBuf (ISetField p val) + TTC Elaboratable_Field_Update where + toBuf (Elaboratable_Set_Field p val) = do tag 0; toBuf p; toBuf val - toBuf (ISetFieldApp p val) + toBuf (Elaboratable_Apply_To_Field p val) = do tag 1; toBuf p; toBuf val fromBuf = case !getTag of 0 => do p <- fromBuf; val <- fromBuf - pure (ISetField p val) + pure (Elaboratable_Set_Field p val) 1 => do p <- fromBuf; val <- fromBuf - pure (ISetFieldApp p val) + pure (Elaboratable_Apply_To_Field p val) _ => corrupt "IFieldUpdate" export @@ -349,71 +349,71 @@ mutual _ => corrupt "FnOpt" export - TTC (IClaimData Name) where - toBuf (MkIClaimData rig vis opts type) + TTC (Elaboratable_Claim_Data Name) where + toBuf (Make_Elaboratable_Claim_Data rig vis opts type) = do toBuf rig; toBuf vis; toBuf opts; toBuf type fromBuf = do rig <- fromBuf vis <- fromBuf opts <- fromBuf type <- fromBuf - pure $ MkIClaimData rig vis opts type + pure $ Make_Elaboratable_Claim_Data rig vis opts type export TTC ImpDecl where - toBuf (IClaim claim) + toBuf (Elaboratable_Claim claim) = do tag 0; toBuf claim - toBuf (IData fc vis mbtot d) + toBuf (Elaboratable_Data_Declaration fc vis mbtot d) = do tag 1; toBuf fc; toBuf vis; toBuf mbtot; toBuf d - toBuf (IDef fc n xs) + toBuf (Elaboratable_Definition fc n xs) = do tag 2; toBuf fc; toBuf n; toBuf xs - toBuf (IParameters fc vis d) + toBuf (Elaboratable_Parameter_Block fc vis d) = do tag 3; toBuf fc; toBuf vis; toBuf d - toBuf (IRecord fc ns vis mbtot r) + toBuf (Elaboratable_Record_Declaration fc ns vis mbtot r) = do tag 4; toBuf fc; toBuf ns; toBuf vis; toBuf mbtot; toBuf r - toBuf (INamespace fc xs ds) + toBuf (Elaboratable_Namespace_Block fc xs ds) = do tag 5; toBuf fc; toBuf xs; toBuf ds - toBuf (ITransform fc n lhs rhs) + toBuf (Elaboratable_Transformation fc n lhs rhs) = do tag 6; toBuf fc; toBuf n; toBuf lhs; toBuf rhs - toBuf (IRunElabDecl fc tm) + toBuf (Elaboratable_Run_Elaborator_Declaration fc tm) = do tag 7; toBuf fc; toBuf tm - toBuf (IPragma _ _ f) = throw (InternalError "Can't write Pragma") - toBuf (ILog n) + toBuf (Elaboratable_Pragma _ _ f) = throw (InternalError "Can't write Pragma") + toBuf (Elaboratable_Logging n) = do tag 8; toBuf n - toBuf (IBuiltin fc type name) + toBuf (Elaboratable_Builtin_Declaration fc type name) = do tag 9; toBuf fc; toBuf type; toBuf name - toBuf (IFail {}) + toBuf (Elaboratable_Expected_Failure {}) = pure () fromBuf = case !getTag of 0 => do claimData <- fromBuf - pure (IClaim claimData) + pure (Elaboratable_Claim claimData) 1 => do fc <- fromBuf; vis <- fromBuf mbtot <- fromBuf; d <- fromBuf - pure (IData fc vis mbtot d) + pure (Elaboratable_Data_Declaration fc vis mbtot d) 2 => do fc <- fromBuf; n <- fromBuf xs <- fromBuf - pure (IDef fc n xs) + pure (Elaboratable_Definition fc n xs) 3 => do fc <- fromBuf; vis <- fromBuf d <- fromBuf - pure (IParameters fc vis d) + pure (Elaboratable_Parameter_Block fc vis d) 4 => do fc <- fromBuf; ns <- fromBuf; vis <- fromBuf; mbtot <- fromBuf; r <- fromBuf - pure (IRecord fc ns vis mbtot r) + pure (Elaboratable_Record_Declaration fc ns vis mbtot r) 5 => do fc <- fromBuf; xs <- fromBuf ds <- fromBuf - pure (INamespace fc xs ds) + pure (Elaboratable_Namespace_Block fc xs ds) 6 => do fc <- fromBuf; n <- fromBuf lhs <- fromBuf; rhs <- fromBuf - pure (ITransform fc n lhs rhs) + pure (Elaboratable_Transformation fc n lhs rhs) 7 => do fc <- fromBuf; tm <- fromBuf - pure (IRunElabDecl fc tm) + pure (Elaboratable_Run_Elaborator_Declaration fc tm) 8 => do n <- fromBuf - pure (ILog n) + pure (Elaboratable_Logging n) 9 => do fc <- fromBuf type <- fromBuf name <- fromBuf - pure (IBuiltin fc type name) + pure (Elaboratable_Builtin_Declaration fc type name) _ => corrupt "ImpDecl" diff --git a/TTImp/TTImp/Traversals.idr b/TTImp/TTImp/Traversals.idr index 79aca98148..97f67e7308 100644 --- a/TTImp/TTImp/Traversals.idr +++ b/TTImp/TTImp/Traversals.idr @@ -56,24 +56,24 @@ parameters (f : RawImp' nm -> RawImp' nm) export mapImpDecl : ImpDecl' nm -> ImpDecl' nm - mapImpDecl (IClaim (MkWithData fc (MkIClaimData rig vis opts ty))) - = IClaim (MkWithData fc (MkIClaimData rig vis (map mapFnOpt opts) (map mapTTImp ty))) - mapImpDecl (IData fc vis mtreq dat) = IData fc vis mtreq (mapImpData dat) - mapImpDecl (IDef fc n cls) = IDef fc n (map mapImpClause cls) - mapImpDecl (IParameters fc params xs) = IParameters fc params (assert_total $ map mapImpDecl xs) - mapImpDecl (IRecord fc mstr x y rec) = IRecord fc mstr x y (map mapImpRecord rec) - mapImpDecl (IFail fc mstr xs) = IFail fc mstr (assert_total $ map mapImpDecl xs) - mapImpDecl (INamespace fc mi xs) = INamespace fc mi (assert_total $ map mapImpDecl xs) - mapImpDecl (ITransform fc n t u) = ITransform fc n (mapTTImp t) (mapTTImp u) - mapImpDecl (IRunElabDecl fc t) = IRunElabDecl fc (mapTTImp t) - mapImpDecl (IPragma fc ns g) = IPragma fc ns g - mapImpDecl (ILog x) = ILog x - mapImpDecl (IBuiltin fc x n) = IBuiltin fc x n + mapImpDecl (Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data rig vis opts ty))) + = Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data rig vis (map mapFnOpt opts) (map mapTTImp ty))) + mapImpDecl (Elaboratable_Data_Declaration fc vis mtreq dat) = Elaboratable_Data_Declaration fc vis mtreq (mapImpData dat) + mapImpDecl (Elaboratable_Definition fc n cls) = Elaboratable_Definition fc n (map mapImpClause cls) + mapImpDecl (Elaboratable_Parameter_Block fc params xs) = Elaboratable_Parameter_Block fc params (assert_total $ map mapImpDecl xs) + mapImpDecl (Elaboratable_Record_Declaration fc mstr x y rec) = Elaboratable_Record_Declaration fc mstr x y (map mapImpRecord rec) + mapImpDecl (Elaboratable_Expected_Failure fc mstr xs) = Elaboratable_Expected_Failure fc mstr (assert_total $ map mapImpDecl xs) + mapImpDecl (Elaboratable_Namespace_Block fc mi xs) = Elaboratable_Namespace_Block fc mi (assert_total $ map mapImpDecl xs) + mapImpDecl (Elaboratable_Transformation fc n t u) = Elaboratable_Transformation fc n (mapTTImp t) (mapTTImp u) + mapImpDecl (Elaboratable_Run_Elaborator_Declaration fc t) = Elaboratable_Run_Elaborator_Declaration fc (mapTTImp t) + mapImpDecl (Elaboratable_Pragma fc ns g) = Elaboratable_Pragma fc ns g + mapImpDecl (Elaboratable_Logging x) = Elaboratable_Logging x + mapImpDecl (Elaboratable_Builtin_Declaration fc x n) = Elaboratable_Builtin_Declaration fc x n export - mapIFieldUpdate : IFieldUpdate' nm -> IFieldUpdate' nm - mapIFieldUpdate (ISetField path t) = ISetField path (mapTTImp t) - mapIFieldUpdate (ISetFieldApp path t) = ISetFieldApp path (mapTTImp t) + mapIFieldUpdate : Elaboratable_Field_Update' nm -> Elaboratable_Field_Update' nm + mapIFieldUpdate (Elaboratable_Set_Field path t) = Elaboratable_Set_Field path (mapTTImp t) + mapIFieldUpdate (Elaboratable_Apply_To_Field path t) = Elaboratable_Apply_To_Field path (mapTTImp t) export mapAltType : AltType' nm -> AltType' nm @@ -81,42 +81,42 @@ parameters (f : RawImp' nm -> RawImp' nm) mapAltType Unique = Unique mapAltType (UniqueDefault t) = UniqueDefault (mapTTImp t) - mapTTImp t@(IVar {}) = f t - mapTTImp (IPi fc rig pinfo x argTy retTy) - = f $ IPi fc rig (mapPiInfo pinfo) x (mapTTImp argTy) (mapTTImp retTy) - mapTTImp (ILam fc rig pinfo x argTy lamTy) - = f $ ILam fc rig (mapPiInfo pinfo) x (mapTTImp argTy) (mapTTImp lamTy) - mapTTImp (ILet fc lhsFC rig n nTy nVal scope) - = f $ ILet fc lhsFC rig n (mapTTImp nTy) (mapTTImp nVal) (mapTTImp scope) - mapTTImp (ICase fc opts t ty cls) - = f $ ICase fc opts (mapTTImp t) (mapTTImp ty) (assert_total $ map mapImpClause cls) - mapTTImp (ILocal fc xs t) - = f $ ILocal fc (assert_total $ map mapImpDecl xs) (mapTTImp t) - mapTTImp (ICaseLocal fc unm inm args t) = f $ ICaseLocal fc unm inm args (mapTTImp t) - mapTTImp (IUpdate fc upds t) = f $ IUpdate fc (assert_total map mapIFieldUpdate upds) (mapTTImp t) - mapTTImp (IApp fc t u) = f $ IApp fc (mapTTImp t) (mapTTImp u) - mapTTImp (IAutoApp fc t u) = f $ IAutoApp fc (mapTTImp t) (mapTTImp u) - mapTTImp (INamedApp fc t n u) = f $ INamedApp fc (mapTTImp t) n (mapTTImp u) - mapTTImp (IWithApp fc t u) = f $ IWithApp fc (mapTTImp t) (mapTTImp u) - mapTTImp (ISearch fc depth) = f $ ISearch fc depth - mapTTImp (IAlternative fc alt ts) = f $ IAlternative fc (mapAltType alt) (assert_total map mapTTImp ts) - mapTTImp (IRewrite fc t u) = f $ IRewrite fc (mapTTImp t) (mapTTImp u) - mapTTImp (ICoerced fc t) = f $ ICoerced fc (mapTTImp t) - mapTTImp (IBindHere fc bm t) = f $ IBindHere fc bm (mapTTImp t) - mapTTImp (IBindVar fc str) = f $ IBindVar fc str - mapTTImp (IAs fc nameFC side n t) = f $ IAs fc nameFC side n (mapTTImp t) - mapTTImp (IMustUnify fc x t) = f $ IMustUnify fc x (mapTTImp t) - mapTTImp (IDelayed fc lz t) = f $ IDelayed fc lz (mapTTImp t) - mapTTImp (IDelay fc t) = f $ IDelay fc (mapTTImp t) - mapTTImp (IForce fc t) = f $ IForce fc (mapTTImp t) - mapTTImp (IQuote fc t) = f $ IQuote fc (mapTTImp t) - mapTTImp (IQuoteName fc n) = f $ IQuoteName fc n - mapTTImp (IQuoteDecl fc xs) = f $ IQuoteDecl fc (assert_total $ map mapImpDecl xs) - mapTTImp (IUnquote fc t) = f $ IUnquote fc (mapTTImp t) - mapTTImp (IRunElab fc re t) = f $ IRunElab fc re (mapTTImp t) - mapTTImp (IPrimVal fc c) = f $ IPrimVal fc c - mapTTImp (IType fc) = f $ IType fc - mapTTImp (IHole fc str) = f $ IHole fc str - mapTTImp (IUnifyLog fc x t) = f $ IUnifyLog fc x (mapTTImp t) + mapTTImp t@(Elaboratable_Name {}) = f t + mapTTImp (Elaboratable_Dependent_Function_Type fc rig pinfo x argTy retTy) + = f $ Elaboratable_Dependent_Function_Type fc rig (mapPiInfo pinfo) x (mapTTImp argTy) (mapTTImp retTy) + mapTTImp (Elaboratable_Lambda fc rig pinfo x argTy lamTy) + = f $ Elaboratable_Lambda fc rig (mapPiInfo pinfo) x (mapTTImp argTy) (mapTTImp lamTy) + mapTTImp (Elaboratable_Binding fc lhsFC rig n nTy nVal scope) + = f $ Elaboratable_Binding fc lhsFC rig n (mapTTImp nTy) (mapTTImp nVal) (mapTTImp scope) + mapTTImp (Elaboratable_Case fc opts t ty cls) + = f $ Elaboratable_Case fc opts (mapTTImp t) (mapTTImp ty) (assert_total $ map mapImpClause cls) + mapTTImp (Elaboratable_Local_Definitions fc xs t) + = f $ Elaboratable_Local_Definitions fc (assert_total $ map mapImpDecl xs) (mapTTImp t) + mapTTImp (Elaboratable_Case_Local_Definition fc unm inm args t) = f $ Elaboratable_Case_Local_Definition fc unm inm args (mapTTImp t) + mapTTImp (Elaboratable_Record_Update fc upds t) = f $ Elaboratable_Record_Update fc (assert_total map mapIFieldUpdate upds) (mapTTImp t) + mapTTImp (Elaboratable_Apply fc t u) = f $ Elaboratable_Apply fc (mapTTImp t) (mapTTImp u) + mapTTImp (Elaboratable_Automatic_Apply fc t u) = f $ Elaboratable_Automatic_Apply fc (mapTTImp t) (mapTTImp u) + mapTTImp (Elaboratable_Named_Apply fc t n u) = f $ Elaboratable_Named_Apply fc (mapTTImp t) n (mapTTImp u) + mapTTImp (Elaboratable_With_Apply fc t u) = f $ Elaboratable_With_Apply fc (mapTTImp t) (mapTTImp u) + mapTTImp (Elaboratable_Search fc depth) = f $ Elaboratable_Search fc depth + mapTTImp (Elaboratable_Alternative fc alt ts) = f $ Elaboratable_Alternative fc (mapAltType alt) (assert_total map mapTTImp ts) + mapTTImp (Elaboratable_Rewrite fc t u) = f $ Elaboratable_Rewrite fc (mapTTImp t) (mapTTImp u) + mapTTImp (Elaboratable_Coerced fc t) = f $ Elaboratable_Coerced fc (mapTTImp t) + mapTTImp (Elaboratable_Bind_Here fc bm t) = f $ Elaboratable_Bind_Here fc bm (mapTTImp t) + mapTTImp (Elaboratable_Bind_Name fc str) = f $ Elaboratable_Bind_Name fc str + mapTTImp (Elaboratable_As_Pattern fc nameFC side n t) = f $ Elaboratable_As_Pattern fc nameFC side n (mapTTImp t) + mapTTImp (Elaboratable_Must_Unify fc x t) = f $ Elaboratable_Must_Unify fc x (mapTTImp t) + mapTTImp (Elaboratable_Delayed_Type fc lz t) = f $ Elaboratable_Delayed_Type fc lz (mapTTImp t) + mapTTImp (Elaboratable_Delay fc t) = f $ Elaboratable_Delay fc (mapTTImp t) + mapTTImp (Elaboratable_Force fc t) = f $ Elaboratable_Force fc (mapTTImp t) + mapTTImp (Elaboratable_Quote fc t) = f $ Elaboratable_Quote fc (mapTTImp t) + mapTTImp (Elaboratable_Quote_Name fc n) = f $ Elaboratable_Quote_Name fc n + mapTTImp (Elaboratable_Quote_Declarations fc xs) = f $ Elaboratable_Quote_Declarations fc (assert_total $ map mapImpDecl xs) + mapTTImp (Elaboratable_Unquote fc t) = f $ Elaboratable_Unquote fc (mapTTImp t) + mapTTImp (Elaboratable_Run_Elaborator fc re t) = f $ Elaboratable_Run_Elaborator fc re (mapTTImp t) + mapTTImp (Elaboratable_Primitive_Value fc c) = f $ Elaboratable_Primitive_Value fc c + mapTTImp (Elaboratable_Type_Universe fc) = f $ Elaboratable_Type_Universe fc + mapTTImp (Elaboratable_Hole fc str) = f $ Elaboratable_Hole fc str + mapTTImp (Elaboratable_Unification_Log fc x t) = f $ Elaboratable_Unification_Log fc x (mapTTImp t) mapTTImp (Implicit fc bindIfUnsolved) = f $ Implicit fc bindIfUnsolved - mapTTImp (IWithUnambigNames fc xs t) = f $ IWithUnambigNames fc xs (mapTTImp t) + mapTTImp (Elaboratable_With_Unambiguous_Names fc xs t) = f $ Elaboratable_With_Unambiguous_Names fc xs (mapTTImp t) diff --git a/TTImp/Unelab.idr b/TTImp/Unelab.idr index b5ddeb5809..da2193c61e 100644 --- a/TTImp/Unelab.idr +++ b/TTImp/Unelab.idr @@ -71,7 +71,7 @@ mutual Env Term vars -> Name -> List (Term vars) -> - Core (Maybe IRawImp) + Core (Maybe Kinded_Elaboratable_Term) unelabCase nest env n args = do defs <- get Ctxt Just glob <- lookupCtxtExact n (gamma defs) @@ -128,7 +128,7 @@ mutual mkClause : FC -> Nat -> List (Term vars) -> (vs ** (Env Term vs, Term vs, Term vs)) -> - Core (Maybe IImpClause) + Core (Maybe Kinded_Elaboratable_Clause) mkClause fc argpos args (vs ** (clauseEnv, lhs, rhs)) = do logTerm "unelab.case.clause" 20 "Unelaborating clause" lhs let patArgs = snd (getFnArgs lhs) @@ -149,7 +149,7 @@ mutual ||| Once we have the scrutinee `e`, we can form `case e of` and so focus ||| on manufacturing the clauses. mkCase : List (vs ** (Env Term vs, Term vs, Term vs)) -> - (argpos : Nat) -> List (Term vars) -> Core (Maybe IRawImp) + (argpos : Nat) -> List (Term vars) -> Core (Maybe Kinded_Elaboratable_Term) mkCase pats argpos args = do unless (null args) $ log "unelab.case.clause" 20 $ unwords $ "Ignoring" :: map show args @@ -160,23 +160,23 @@ mutual Just pats' <- map sequence $ traverse (mkClause fc argpos args) pats | _ => pure Nothing -- TODO: actually grab the fnopts? - pure $ Just $ ICase fc [] tm (Implicit fc False) pats' + pure $ Just $ Elaboratable_Case fc [] tm (Implicit fc False) pats' - dropParams : List (Name, Nat) -> (IRawImp, Glued vars) -> - Core (IRawImp, Glued vars) + dropParams : List (Name, Nat) -> (Kinded_Elaboratable_Term, Glued vars) -> + Core (Kinded_Elaboratable_Term, Glued vars) dropParams nest (tm, ty) = case getFnArgs tm [] of - (IVar fc n, args) => + (Elaboratable_Name fc n, args) => case lookup (rawName n) nest of Nothing => pure (tm, ty) - Just i => pure $ (apply (IVar fc n) (drop i args), ty) + Just i => pure $ (apply (Elaboratable_Name fc n) (drop i args), ty) _ => pure (tm, ty) where - apply : IRawImp -> List IArg -> IRawImp + apply : Kinded_Elaboratable_Term -> List Kinded_Elaboratable_Argument -> Kinded_Elaboratable_Term apply tm [] = tm - apply tm (Explicit fc a :: args) = apply (IApp fc tm a) args - apply tm (Auto fc a :: args) = apply (IAutoApp fc tm a) args - apply tm (Named fc n a :: args) = apply (INamedApp fc tm n a) args + apply tm (Explicit fc a :: args) = apply (Elaboratable_Apply fc tm a) args + apply tm (Auto fc a :: args) = apply (Elaboratable_Automatic_Apply fc tm a) args + apply tm (Named fc n a :: args) = apply (Elaboratable_Named_Apply fc tm n a) args -- Turn a term back into an unannotated TTImp. Returns the type of the -- unelaborated term so that we can work out where to put the implicit @@ -188,7 +188,7 @@ mutual (umode : UnelabMode) -> (nest : List (Name, Nat)) -> Env Term vars -> Term vars -> - Core (IRawImp, Glued vars) + Core (Kinded_Elaboratable_Term, Glued vars) unelabTy umode nest env tm = dropParams nest !(unelabTy' umode nest env tm) @@ -197,18 +197,18 @@ mutual (umode : UnelabMode) -> (nest : List (Name, Nat)) -> Env Term vars -> Term vars -> - Core (IRawImp, Glued vars) + Core (Kinded_Elaboratable_Term, Glued vars) unelabTy' umode nest env (Local fc _ idx p) = do let nm = nameAt p log "unelab.case" 20 $ "Found local name: " ++ show nm let ty = gnf env (binderType (getBinder p env)) - pure (IVar fc (MkKindedName (Just Bound) nm nm), ty) + pure (Elaboratable_Name fc (MkKindedName (Just Bound) nm nm), ty) unelabTy' umode nest env (Ref fc nt n) = do defs <- get Ctxt Just ty <- lookupTyExact n (gamma defs) | Nothing => case umode of ImplicitHoles => pure (Implicit fc True, gErased fc) - _ => pure (IVar fc (MkKindedName (Just nt) n n), gErased fc) + _ => pure (Elaboratable_Name fc (MkKindedName (Just nt) n n), gErased fc) fn <- getFullName n n' <- case umode of NoSugar _ => pure fn @@ -219,14 +219,14 @@ mutual , "sugared to", show n' ] - pure (IVar fc (MkKindedName (Just nt) fn n'), gnf env (embed ty)) + pure (Elaboratable_Name fc (MkKindedName (Just nt) fn n'), gnf env (embed ty)) unelabTy' umode nest env (Meta fc n i args) = do defs <- get Ctxt let mkn = nameRoot n def <- lookupDefExact (Resolved i) (gamma defs) let term = case def of - (Just (BySearch _ d _)) => ISearch fc d - _ => IHole fc mkn + (Just (BySearch _ d _)) => Elaboratable_Search fc d + _ => Elaboratable_Hole fc mkn Just ty <- lookupTyExact (Resolved i) (gamma defs) | Nothing => case umode of ImplicitHoles => pure (Implicit fc True, gErased fc) @@ -276,46 +276,46 @@ mutual case fnty of NBind _ x (Pi _ rig Explicit ty) sc => do sc' <- sc defs (toClosure defaultOpts env arg) - pure (IApp fc fn' arg', + pure (Elaboratable_Apply fc fn' arg', glueBack defs env sc') NBind _ x (Pi _ rig p ty) sc => do sc' <- sc defs (toClosure defaultOpts env arg) - pure (INamedApp fc fn' x arg', + pure (Elaboratable_Named_Apply fc fn' x arg', glueBack defs env sc') - _ => pure (IApp fc fn' arg', gErased fc) + _ => pure (Elaboratable_Apply fc fn' arg', gErased fc) unelabTy' umode nest env (As fc s p tm) = do (p', _) <- unelabTy' umode nest env p (tm', ty) <- unelabTy' umode nest env tm case p' of - IVar _ n => + Elaboratable_Name _ n => case umode of - NoSugar _ => pure (IAs fc (getLoc p) s n.rawName tm', ty) + NoSugar _ => pure (Elaboratable_As_Pattern fc (getLoc p) s n.rawName tm', ty) _ => pure (tm', ty) _ => pure (tm', ty) -- Should never happen! unelabTy' umode nest env (TDelayed fc r tm) = do (tm', ty) <- unelabTy' umode nest env tm defs <- get Ctxt - pure (IDelayed fc r tm', gErased fc) + pure (Elaboratable_Delayed_Type fc r tm', gErased fc) unelabTy' umode nest env (TDelay fc r _ tm) = do (tm', ty) <- unelabTy' umode nest env tm defs <- get Ctxt - pure (IDelay fc tm', gErased fc) + pure (Elaboratable_Delay fc tm', gErased fc) unelabTy' umode nest env (TForce fc r tm) = do (tm', ty) <- unelabTy' umode nest env tm defs <- get Ctxt - pure (IForce fc tm', gErased fc) - unelabTy' umode nest env (PrimVal fc c) = pure (IPrimVal fc c, gErased fc) + pure (Elaboratable_Force fc tm', gErased fc) + unelabTy' umode nest env (PrimVal fc c) = pure (Elaboratable_Primitive_Value fc c, gErased fc) unelabTy' umode nest env (Erased fc (Dotted t)) = unelabTy' umode nest env t unelabTy' umode nest env (Erased fc _) = pure (Implicit fc True, gErased fc) - unelabTy' umode nest env (TType fc _) = pure (IType fc, gType fc (MN "top" 0)) + unelabTy' umode nest env (TType fc _) = pure (Elaboratable_Type_Universe fc, gType fc (MN "top" 0)) unelabPi : {vars : _} -> {auto c : Ref Ctxt Defs} -> (umode : UnelabMode) -> (nest : List (Name, Nat)) -> Env Term vars -> PiInfo (Term vars) -> - Core (PiInfo IRawImp) + Core (PiInfo Kinded_Elaboratable_Term) unelabPi umode nest env Explicit = pure Explicit unelabPi umode nest env Implicit = pure Implicit unelabPi umode nest env AutoImplicit = pure AutoImplicit @@ -329,17 +329,17 @@ mutual (nest : List (Name, Nat)) -> FC -> Env Term vars -> (x : Name) -> Binder (Term vars) -> Term (x :: vars) -> - IRawImp -> Term (x :: vars) -> - Core (IRawImp, Glued vars) + Kinded_Elaboratable_Term -> Term (x :: vars) -> + Core (Kinded_Elaboratable_Term, Glued vars) unelabBinder umode nest fc env x (Lam fc' rig p ty) sctm sc scty = do (ty', _) <- unelabTy umode nest env ty p' <- unelabPi umode nest env p - pure (ILam fc rig p' (Just x) ty' sc, + pure (Elaboratable_Lambda fc rig p' (Just x) ty' sc, gnf env (Bind fc x (Pi fc' rig p ty) scty)) unelabBinder umode nest fc env x (Let fc' rig val ty) sctm sc scty = do (val', vty) <- unelabTy umode nest env val (ty', _) <- unelabTy umode nest env ty - pure (ILet fc EmptyFC rig x ty' val' sc, + pure (Elaboratable_Binding fc EmptyFC rig x ty' val' sc, gnf env (Bind fc x (Let fc' rig val ty) scty)) unelabBinder umode nest fc env x (Pi _ rig p ty) sctm sc scty = do (ty', _) <- unelabTy umode nest env ty @@ -349,7 +349,7 @@ mutual else if rig /= top || isDefImp p then Just (UN Underscore) else Nothing - pure (IPi fc rig p' nm ty' sc, gType fc (MN "top" 0)) + pure (Elaboratable_Dependent_Function_Type fc rig p' nm ty' sc, gType fc (MN "top" 0)) where isNoSugar : UnelabMode -> Bool isNoSugar (NoSugar _) = True @@ -363,7 +363,7 @@ mutual unelabBinder umode nest fc env x (PLet fc' rig val ty) sctm sc scty = do (val', vty) <- unelabTy umode nest env val (ty', _) <- unelabTy umode nest env ty - pure (ILet fc EmptyFC rig x ty' val' sc, + pure (Elaboratable_Binding fc EmptyFC rig x ty' val' sc, gnf env (Bind fc x (PLet fc' rig val ty) scty)) unelabBinder umode nest fc env x (PVTy _ rig ty) sctm sc scty = do (ty', _) <- unelabTy umode nest env ty @@ -372,7 +372,7 @@ mutual export unelabNoSugar : {vars : _} -> {auto c : Ref Ctxt Defs} -> - Env Term vars -> Term vars -> Core IRawImp + Env Term vars -> Term vars -> Core Kinded_Elaboratable_Term unelabNoSugar env tm = do tm' <- unelabTy (NoSugar False) [] env tm pure $ fst tm' @@ -380,7 +380,7 @@ unelabNoSugar env tm export unelabUniqueBinders : {vars : _} -> {auto c : Ref Ctxt Defs} -> - Env Term vars -> Term vars -> Core IRawImp + Env Term vars -> Term vars -> Core Kinded_Elaboratable_Term unelabUniqueBinders env tm = do tm' <- unelabTy (NoSugar True) [] env tm pure $ fst tm' @@ -388,7 +388,7 @@ unelabUniqueBinders env tm export unelabNoPatvars : {vars : _} -> {auto c : Ref Ctxt Defs} -> - Env Term vars -> Term vars -> Core IRawImp + Env Term vars -> Term vars -> Core Kinded_Elaboratable_Term unelabNoPatvars env tm = do tm' <- unelabTy ImplicitHoles [] env tm pure $ fst tm' @@ -399,10 +399,10 @@ unelabNest : {vars : _} -> UnelabMode -> List (Name, Nat) -> Env Term vars -> - Term vars -> Core IRawImp + Term vars -> Core Kinded_Elaboratable_Term unelabNest mode nest env (Meta fc n i args) = do let mkn = nameRoot n ++ showScope args - pure (IHole fc mkn) + pure (Elaboratable_Hole fc mkn) where toName : Term vars -> Maybe Name toName (Local _ _ idx p) = Just (nameAt p) @@ -423,5 +423,5 @@ export unelab : {vars : _} -> {auto c : Ref Ctxt Defs} -> Env Term vars -> - Term vars -> Core IRawImp + Term vars -> Core Kinded_Elaboratable_Term unelab = unelabNest Full [] diff --git a/TTImp/Utils.idr b/TTImp/Utils.idr index 7fc30f996b..b8b39e8239 100644 --- a/TTImp/Utils.idr +++ b/TTImp/Utils.idr @@ -25,23 +25,23 @@ genUniqueStr xs x = if x `elem` xs then genUniqueStr xs (x ++ "'") else x -- Used in findBindableNames{,Quot} rawImpFromDecl : ImpDecl -> List RawImp rawImpFromDecl decl = case decl of - IClaim (MkWithData fc1 $ MkIClaimData y z ys ty) => [ty.val] - IData fc1 y _ (MkImpData fc2 n tycon opts datacons) + Elaboratable_Claim (MkWithData fc1 $ Make_Elaboratable_Claim_Data y z ys ty) => [ty.val] + Elaboratable_Data_Declaration fc1 y _ (MkImpData fc2 n tycon opts datacons) => maybe id (::) tycon $ map val datacons - IData fc1 y _ (MkImpLater fc2 n tycon) => [tycon] - IDef fc1 y ys => getFromClause !ys - IParameters fc1 ys zs => rawImpFromDecl !zs ++ map getParamTy (forget ys) - IRecord fc1 y z _ (MkWithData _ (MkImpRecord header body)) => do + Elaboratable_Data_Declaration fc1 y _ (MkImpLater fc2 n tycon) => [tycon] + Elaboratable_Definition fc1 y ys => getFromClause !ys + Elaboratable_Parameter_Block fc1 ys zs => rawImpFromDecl !zs ++ map getParamTy (forget ys) + Elaboratable_Record_Declaration fc1 y z _ (MkWithData _ (MkImpRecord header body)) => do binder <- header.val field <- body.val getFromPiInfo binder.val.info ++ [binder.val.boundType] ++ getFromIField field - IFail fc1 msg zs => rawImpFromDecl !zs - INamespace fc1 ys zs => rawImpFromDecl !zs - ITransform fc1 y z w => [z, w] - IRunElabDecl fc1 y => [] -- Not sure about this either - IPragma _ _ f => [] - ILog k => [] - IBuiltin {} => [] + Elaboratable_Expected_Failure fc1 msg zs => rawImpFromDecl !zs + Elaboratable_Namespace_Block fc1 ys zs => rawImpFromDecl !zs + Elaboratable_Transformation fc1 y z w => [z, w] + Elaboratable_Run_Elaborator_Declaration fc1 y => [] -- Not sure about this either + Elaboratable_Pragma _ _ f => [] + Elaboratable_Logging k => [] + Elaboratable_Builtin_Declaration {} => [] where getParamTy : ImpParameter' RawImp -> RawImp getParamTy binder = binder.val.boundType getFromClause : ImpClause -> List RawImp @@ -51,12 +51,12 @@ rawImpFromDecl decl = case decl of getFromPiInfo : PiInfo RawImp -> List RawImp getFromPiInfo (DefImplicit x) = [x] getFromPiInfo _ = [] - getFromIField : IField -> List RawImp + getFromIField : Elaboratable_Field -> List RawImp getFromIField field = getFromPiInfo field.val.info ++ [field.val.boundType] -- Identify lower case names in argument position, which we can bind later. --- Don't go under case, let, or local bindings, or IAlternative. +-- Don't go under case, let, or local bindings, or Elaboratable_Alternative. -- -- arg: Is the current expression in argument position? (We don't want to implicitly -- bind funtions.) @@ -70,119 +70,119 @@ findBindableNames : (arg : Bool) -> (env : List Name) -> (used : List String) -> findBindableNamesQuot : List Name -> (used : List String) -> RawImp -> List (Name, Name) -findBindableNames True env used (IVar fc nm@(UN (Basic n))) +findBindableNames True env used (Elaboratable_Name fc nm@(UN (Basic n))) -- If the identifier is not bound locally and begins with a lowercase letter.. = if not (nm `elem` env) && lowerFirst n then [(nm, UN $ Basic $ genUniqueStr used n)] else [] -findBindableNames arg env used (IPi fc rig p mn aty retty) +findBindableNames arg env used (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) = let env' = case mn of Nothing => env Just n => n :: env in findBindableNames True env used aty ++ findBindableNames True env' used retty -findBindableNames arg env used (ILam fc rig p mn aty sc) +findBindableNames arg env used (Elaboratable_Lambda fc rig p mn aty sc) = let env' = case mn of Nothing => env Just n => n :: env in findBindableNames True env used aty ++ findBindableNames True env' used sc -findBindableNames arg env used (IApp fc fn av) +findBindableNames arg env used (Elaboratable_Apply fc fn av) = findBindableNames False env used fn ++ findBindableNames True env used av -findBindableNames arg env used (INamedApp fc fn n av) +findBindableNames arg env used (Elaboratable_Named_Apply fc fn n av) = findBindableNames False env used fn ++ findBindableNames True env used av -findBindableNames arg env used (IAutoApp fc fn av) +findBindableNames arg env used (Elaboratable_Automatic_Apply fc fn av) = findBindableNames False env used fn ++ findBindableNames True env used av -findBindableNames arg env used (IWithApp fc fn av) +findBindableNames arg env used (Elaboratable_With_Apply fc fn av) = findBindableNames False env used fn ++ findBindableNames True env used av -findBindableNames arg env used (IAs fc _ _ nm@(UN (Basic n)) pat) +findBindableNames arg env used (Elaboratable_As_Pattern fc _ _ nm@(UN (Basic n)) pat) = (nm, UN $ Basic $ genUniqueStr used n) :: findBindableNames arg env used pat -findBindableNames arg env used (IAs fc _ _ n pat) +findBindableNames arg env used (Elaboratable_As_Pattern fc _ _ n pat) = findBindableNames arg env used pat -findBindableNames arg env used (IMustUnify fc r pat) +findBindableNames arg env used (Elaboratable_Must_Unify fc r pat) = findBindableNames arg env used pat -findBindableNames arg env used (IDelayed fc r t) +findBindableNames arg env used (Elaboratable_Delayed_Type fc r t) = findBindableNames arg env used t -findBindableNames arg env used (IDelay fc t) +findBindableNames arg env used (Elaboratable_Delay fc t) = findBindableNames arg env used t -findBindableNames arg env used (IForce fc t) +findBindableNames arg env used (Elaboratable_Force fc t) = findBindableNames arg env used t -findBindableNames arg env used (IQuote fc t) +findBindableNames arg env used (Elaboratable_Quote fc t) = findBindableNamesQuot env used t -findBindableNames arg env used (IQuoteDecl fc d) +findBindableNames arg env used (Elaboratable_Quote_Declarations fc d) = findBindableNamesQuot env used !(rawImpFromDecl !d) -findBindableNames arg env used (IAlternative fc u alts) +findBindableNames arg env used (Elaboratable_Alternative fc u alts) = concatMap (findBindableNames arg env used) alts -findBindableNames arg env used (IUpdate fc updates tm) +findBindableNames arg env used (Elaboratable_Record_Update fc updates tm) = findBindableNames True env used tm ++ concatMap (findBindableNames True env used . getFieldUpdateTerm) updates -- We've skipped case, let and local - rather than guess where the -- name should be bound, leave it to the programmer findBindableNames arg env used tm = [] -findBindableNamesQuot env used (IPi fc x y z argTy retTy) +findBindableNamesQuot env used (Elaboratable_Dependent_Function_Type fc x y z argTy retTy) = findBindableNamesQuot env used ![argTy, retTy] -findBindableNamesQuot env used (ILam fc x y z argTy lamTy) +findBindableNamesQuot env used (Elaboratable_Lambda fc x y z argTy lamTy) = findBindableNamesQuot env used ![argTy, lamTy] -findBindableNamesQuot env used (ILet fc lhsfc x y nTy nVal scope) +findBindableNamesQuot env used (Elaboratable_Binding fc lhsfc x y nTy nVal scope) = findBindableNamesQuot env used ![nTy, nVal, scope] -findBindableNamesQuot env used (ICase fc _ x ty xs) +findBindableNamesQuot env used (Elaboratable_Case fc _ x ty xs) = findBindableNamesQuot env used !([x, ty] ++ getRawImp !xs) where getRawImp : ImpClause -> List RawImp getRawImp (PatClause fc1 lhs rhs) = [lhs, rhs] getRawImp (WithClause fc1 lhs rig wval prf flags ys) = [wval, lhs] ++ getRawImp !ys getRawImp (ImpossibleClause fc1 lhs) = [lhs] -findBindableNamesQuot env used (ILocal fc xs x) +findBindableNamesQuot env used (Elaboratable_Local_Definitions fc xs x) = findBindableNamesQuot env used !(x :: rawImpFromDecl !xs) -findBindableNamesQuot env used (ICaseLocal fc uname internalName args x) +findBindableNamesQuot env used (Elaboratable_Case_Local_Definition fc uname internalName args x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (IApp fc x y) +findBindableNamesQuot env used (Elaboratable_Apply fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (INamedApp fc x y z) +findBindableNamesQuot env used (Elaboratable_Named_Apply fc x y z) = findBindableNamesQuot env used ![x, z] -findBindableNamesQuot env used (IAutoApp fc x y) +findBindableNamesQuot env used (Elaboratable_Automatic_Apply fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (IWithApp fc x y) +findBindableNamesQuot env used (Elaboratable_With_Apply fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (IRewrite fc x y) +findBindableNamesQuot env used (Elaboratable_Rewrite fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (ICoerced fc x) +findBindableNamesQuot env used (Elaboratable_Coerced fc x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (IBindHere fc x y) +findBindableNamesQuot env used (Elaboratable_Bind_Here fc x y) = findBindableNamesQuot env used y -findBindableNamesQuot env used (IUpdate fc xs x) +findBindableNamesQuot env used (Elaboratable_Record_Update fc xs x) = findBindableNamesQuot env used !(x :: map getFieldUpdateTerm xs) -findBindableNamesQuot env used (IAs fc nfc x y z) +findBindableNamesQuot env used (Elaboratable_As_Pattern fc nfc x y z) = findBindableNamesQuot env used z -findBindableNamesQuot env used (IDelayed fc x y) +findBindableNamesQuot env used (Elaboratable_Delayed_Type fc x y) = findBindableNamesQuot env used y -findBindableNamesQuot env used (IDelay fc x) +findBindableNamesQuot env used (Elaboratable_Delay fc x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (IForce fc x) +findBindableNamesQuot env used (Elaboratable_Force fc x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (IUnquote fc x) +findBindableNamesQuot env used (Elaboratable_Unquote fc x) = findBindableNames True env used x -findBindableNamesQuot env used (IWithUnambigNames fc xs x) +findBindableNamesQuot env used (Elaboratable_With_Unambiguous_Names fc xs x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (IVar fc x) = [] -findBindableNamesQuot env used (ISearch fc depth) = [] -findBindableNamesQuot env used (IAlternative fc x xs) = [] -findBindableNamesQuot env used (IBindVar fc x) = [] -findBindableNamesQuot env used (IPrimVal fc c) = [] -findBindableNamesQuot env used (IType fc) = [] -findBindableNamesQuot env used (IHole fc x) = [] +findBindableNamesQuot env used (Elaboratable_Name fc x) = [] +findBindableNamesQuot env used (Elaboratable_Search fc depth) = [] +findBindableNamesQuot env used (Elaboratable_Alternative fc x xs) = [] +findBindableNamesQuot env used (Elaboratable_Bind_Name fc x) = [] +findBindableNamesQuot env used (Elaboratable_Primitive_Value fc c) = [] +findBindableNamesQuot env used (Elaboratable_Type_Universe fc) = [] +findBindableNamesQuot env used (Elaboratable_Hole fc x) = [] findBindableNamesQuot env used (Implicit fc bindIfUnsolved) = [] -- These are the ones I'm not sure about -findBindableNamesQuot env used (IMustUnify fc x y) +findBindableNamesQuot env used (Elaboratable_Must_Unify fc x y) = findBindableNamesQuot env used y -findBindableNamesQuot env used (IUnifyLog fc k x) +findBindableNamesQuot env used (Elaboratable_Unification_Log fc k x) = findBindableNamesQuot env used x -- Should f `(g `(List ~(x))) bind "x" as a parameter to "f"? -- Depends how (or if) recursive quoting works -findBindableNamesQuot env used (IQuote fc x) = [] -findBindableNamesQuot env used (IQuoteName fc x) = [] -findBindableNamesQuot env used (IQuoteDecl fc xs) = [] -findBindableNamesQuot env used (IRunElab fc _ x) = [] +findBindableNamesQuot env used (Elaboratable_Quote fc x) = [] +findBindableNamesQuot env used (Elaboratable_Quote_Name fc x) = [] +findBindableNamesQuot env used (Elaboratable_Quote_Declarations fc xs) = [] +findBindableNamesQuot env used (Elaboratable_Run_Elaborator fc _ x) = [] ||| Lower-case names normally become implicit binders. A lower-case type or ||| data constructor introduced by Idric choice syntax is a global name @@ -233,43 +233,43 @@ findUniqueBindableNames fc arg env used t export findAllNames : (env : List Name) -> RawImp -> List Name -findAllNames env (IVar fc n) +findAllNames env (Elaboratable_Name fc n) = if not (n `elem` env) then [n] else [] -findAllNames env (IPi fc rig p mn aty retty) +findAllNames env (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) = let env' = case mn of Nothing => env Just n => n :: env in findAllNames env aty ++ findAllNames env' retty -findAllNames env (ILam fc rig p mn aty sc) +findAllNames env (Elaboratable_Lambda fc rig p mn aty sc) = let env' = case mn of Nothing => env Just n => n :: env in findAllNames env' aty ++ findAllNames env' sc -findAllNames env (IApp fc fn av) +findAllNames env (Elaboratable_Apply fc fn av) = findAllNames env fn ++ findAllNames env av -findAllNames env (INamedApp fc fn n av) +findAllNames env (Elaboratable_Named_Apply fc fn n av) = findAllNames env fn ++ findAllNames env av -findAllNames env (IAutoApp fc fn av) +findAllNames env (Elaboratable_Automatic_Apply fc fn av) = findAllNames env fn ++ findAllNames env av -findAllNames env (IWithApp fc fn av) +findAllNames env (Elaboratable_With_Apply fc fn av) = findAllNames env fn ++ findAllNames env av -findAllNames env (IAs fc _ _ n pat) +findAllNames env (Elaboratable_As_Pattern fc _ _ n pat) = n :: findAllNames env pat -findAllNames env (IMustUnify fc r pat) +findAllNames env (Elaboratable_Must_Unify fc r pat) = findAllNames env pat -findAllNames env (IDelayed fc r t) +findAllNames env (Elaboratable_Delayed_Type fc r t) = findAllNames env t -findAllNames env (IDelay fc t) +findAllNames env (Elaboratable_Delay fc t) = findAllNames env t -findAllNames env (IForce fc t) +findAllNames env (Elaboratable_Force fc t) = findAllNames env t -findAllNames env (IQuote fc t) +findAllNames env (Elaboratable_Quote fc t) = findAllNames env t -findAllNames env (IUnquote fc t) +findAllNames env (Elaboratable_Unquote fc t) = findAllNames env t -findAllNames env (IAlternative fc u alts) +findAllNames env (Elaboratable_Alternative fc u alts) = concatMap (findAllNames env) alts -findAllNames env (IUpdate fc updates tm) +findAllNames env (Elaboratable_Record_Update fc updates tm) = findAllNames env tm ++ concatMap (findAllNames env . getFieldUpdateTerm) updates ++ concatMap (map (UN . Basic) . getFieldUpdatePath) updates @@ -281,29 +281,29 @@ findAllNames env tm = [] -- the ones that mean the declaration will be added). export findIBindVars : RawImp -> List Name -findIBindVars (IPi fc rig p mn aty retty) +findIBindVars (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) = findIBindVars aty ++ findIBindVars retty -findIBindVars (ILam fc rig p mn aty sc) +findIBindVars (Elaboratable_Lambda fc rig p mn aty sc) = findIBindVars aty ++ findIBindVars sc -findIBindVars (IApp fc fn av) +findIBindVars (Elaboratable_Apply fc fn av) = findIBindVars fn ++ findIBindVars av -findIBindVars (INamedApp fc fn n av) +findIBindVars (Elaboratable_Named_Apply fc fn n av) = findIBindVars fn ++ findIBindVars av -findIBindVars (IAutoApp fc fn av) +findIBindVars (Elaboratable_Automatic_Apply fc fn av) = findIBindVars fn ++ findIBindVars av -findIBindVars (IWithApp fc fn av) +findIBindVars (Elaboratable_With_Apply fc fn av) = findIBindVars fn ++ findIBindVars av -findIBindVars (IBindVar fc v) +findIBindVars (Elaboratable_Bind_Name fc v) = [v] -findIBindVars (IDelayed fc r t) +findIBindVars (Elaboratable_Delayed_Type fc r t) = findIBindVars t -findIBindVars (IDelay fc t) +findIBindVars (Elaboratable_Delay fc t) = findIBindVars t -findIBindVars (IForce fc t) +findIBindVars (Elaboratable_Force fc t) = findIBindVars t -findIBindVars (IAlternative fc u alts) +findIBindVars (Elaboratable_Alternative fc u alts) = concatMap findIBindVars alts -findIBindVars (IUpdate fc updates tm) +findIBindVars (Elaboratable_Record_Update fc updates tm) = findIBindVars tm ++ concatMap (findIBindVars . getFieldUpdateTerm) updates -- We've skipped case, let and local - rather than guess where the -- name should be bound, leave it to the programmer @@ -314,63 +314,63 @@ mutual -- TODO association list should be map (should the `List Name` be a set as well?) substNames' : Bool -> List Name -> List (Name, RawImp) -> RawImp -> RawImp - substNames' False bound ps (IVar fc n) + substNames' False bound ps (Elaboratable_Name fc n) = if not (n `elem` bound) then case lookup n ps of Just t => t - _ => IVar fc n - else IVar fc n - substNames' True bound ps (IBindVar fc n) + _ => Elaboratable_Name fc n + else Elaboratable_Name fc n + substNames' True bound ps (Elaboratable_Bind_Name fc n) = if not (n `elem` bound) then case lookup n ps of Just t => t - _ => IBindVar fc n - else IBindVar fc n - substNames' bvar bound ps (IPi fc r p mn argTy retTy) + _ => Elaboratable_Bind_Name fc n + else Elaboratable_Bind_Name fc n + substNames' bvar bound ps (Elaboratable_Dependent_Function_Type fc r p mn argTy retTy) = let bound' = maybe bound (\n => n :: bound) mn in - IPi fc r p mn (substNames' bvar bound ps argTy) + Elaboratable_Dependent_Function_Type fc r p mn (substNames' bvar bound ps argTy) (substNames' bvar bound' ps retTy) - substNames' bvar bound ps (ILam fc r p mn argTy scope) + substNames' bvar bound ps (Elaboratable_Lambda fc r p mn argTy scope) = let bound' = maybe bound (\n => n :: bound) mn in - ILam fc r p mn (substNames' bvar bound ps argTy) + Elaboratable_Lambda fc r p mn (substNames' bvar bound ps argTy) (substNames' bvar bound' ps scope) - substNames' bvar bound ps (ILet fc lhsFC r n nTy nVal scope) + substNames' bvar bound ps (Elaboratable_Binding fc lhsFC r n nTy nVal scope) = let bound' = n :: bound in - ILet fc lhsFC r n (substNames' bvar bound ps nTy) + Elaboratable_Binding fc lhsFC r n (substNames' bvar bound ps nTy) (substNames' bvar bound ps nVal) (substNames' bvar bound' ps scope) - substNames' bvar bound ps (ICase fc opts y ty xs) - = ICase fc opts + substNames' bvar bound ps (Elaboratable_Case fc opts y ty xs) + = Elaboratable_Case fc opts (substNames' bvar bound ps y) (substNames' bvar bound ps ty) (map (substNamesClause' bvar bound ps) xs) - substNames' bvar bound ps (ILocal fc xs y) + substNames' bvar bound ps (Elaboratable_Local_Definitions fc xs y) = let bound' = definedInBlock emptyNS xs ++ bound in - ILocal fc (map (substNamesDecl' bvar bound ps) xs) + Elaboratable_Local_Definitions fc (map (substNamesDecl' bvar bound ps) xs) (substNames' bvar bound' ps y) - substNames' bvar bound ps (IApp fc fn arg) - = IApp fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) - substNames' bvar bound ps (INamedApp fc fn y arg) - = INamedApp fc (substNames' bvar bound ps fn) y (substNames' bvar bound ps arg) - substNames' bvar bound ps (IAutoApp fc fn arg) - = IAutoApp fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) - substNames' bvar bound ps (IWithApp fc fn arg) - = IWithApp fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) - substNames' bvar bound ps (IAlternative fc y xs) - = IAlternative fc y (map (substNames' bvar bound ps) xs) - substNames' bvar bound ps (ICoerced fc y) - = ICoerced fc (substNames' bvar bound ps y) - substNames' bvar bound ps (IAs fc nameFC s y pattern) - = IAs fc nameFC s y (substNames' bvar bound ps pattern) - substNames' bvar bound ps (IMustUnify fc r pattern) - = IMustUnify fc r (substNames' bvar bound ps pattern) - substNames' bvar bound ps (IDelayed fc r t) - = IDelayed fc r (substNames' bvar bound ps t) - substNames' bvar bound ps (IDelay fc t) - = IDelay fc (substNames' bvar bound ps t) - substNames' bvar bound ps (IForce fc t) - = IForce fc (substNames' bvar bound ps t) - substNames' bvar bound ps (IUpdate fc updates tm) - = IUpdate fc (map (mapFieldUpdateTerm $ substNames' bvar bound ps) updates) + substNames' bvar bound ps (Elaboratable_Apply fc fn arg) + = Elaboratable_Apply fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) + substNames' bvar bound ps (Elaboratable_Named_Apply fc fn y arg) + = Elaboratable_Named_Apply fc (substNames' bvar bound ps fn) y (substNames' bvar bound ps arg) + substNames' bvar bound ps (Elaboratable_Automatic_Apply fc fn arg) + = Elaboratable_Automatic_Apply fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) + substNames' bvar bound ps (Elaboratable_With_Apply fc fn arg) + = Elaboratable_With_Apply fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) + substNames' bvar bound ps (Elaboratable_Alternative fc y xs) + = Elaboratable_Alternative fc y (map (substNames' bvar bound ps) xs) + substNames' bvar bound ps (Elaboratable_Coerced fc y) + = Elaboratable_Coerced fc (substNames' bvar bound ps y) + substNames' bvar bound ps (Elaboratable_As_Pattern fc nameFC s y pattern) + = Elaboratable_As_Pattern fc nameFC s y (substNames' bvar bound ps pattern) + substNames' bvar bound ps (Elaboratable_Must_Unify fc r pattern) + = Elaboratable_Must_Unify fc r (substNames' bvar bound ps pattern) + substNames' bvar bound ps (Elaboratable_Delayed_Type fc r t) + = Elaboratable_Delayed_Type fc r (substNames' bvar bound ps t) + substNames' bvar bound ps (Elaboratable_Delay fc t) + = Elaboratable_Delay fc (substNames' bvar bound ps t) + substNames' bvar bound ps (Elaboratable_Force fc t) + = Elaboratable_Force fc (substNames' bvar bound ps t) + substNames' bvar bound ps (Elaboratable_Record_Update fc updates tm) + = Elaboratable_Record_Update fc (map (mapFieldUpdateTerm $ substNames' bvar bound ps) updates) (substNames' bvar bound ps tm) substNames' bvar bound ps tm = tm @@ -401,16 +401,16 @@ mutual substNamesDecl' : Bool -> List Name -> List (Name, RawImp ) -> ImpDecl -> ImpDecl - substNamesDecl' bvar bound ps (IClaim claim) - = IClaim $ map {type $= map (substNames' bvar bound ps)} claim - substNamesDecl' bvar bound ps (IDef fc n cs) - = IDef fc n (map (substNamesClause' bvar bound ps) cs) - substNamesDecl' bvar bound ps (IData fc vis mbtot d) - = IData fc vis mbtot (substNamesData' bvar bound ps d) - substNamesDecl' bvar bound ps (IFail fc msg ds) - = IFail fc msg (map (substNamesDecl' bvar bound ps) ds) - substNamesDecl' bvar bound ps (INamespace fc ns ds) - = INamespace fc ns (map (substNamesDecl' bvar bound ps) ds) + substNamesDecl' bvar bound ps (Elaboratable_Claim claim) + = Elaboratable_Claim $ map {type $= map (substNames' bvar bound ps)} claim + substNamesDecl' bvar bound ps (Elaboratable_Definition fc n cs) + = Elaboratable_Definition fc n (map (substNamesClause' bvar bound ps) cs) + substNamesDecl' bvar bound ps (Elaboratable_Data_Declaration fc vis mbtot d) + = Elaboratable_Data_Declaration fc vis mbtot (substNamesData' bvar bound ps d) + substNamesDecl' bvar bound ps (Elaboratable_Expected_Failure fc msg ds) + = Elaboratable_Expected_Failure fc msg (map (substNamesDecl' bvar bound ps) ds) + substNamesDecl' bvar bound ps (Elaboratable_Namespace_Block fc ns ds) + = Elaboratable_Namespace_Block fc ns (map (substNamesDecl' bvar bound ps) ds) substNamesDecl' bvar bound ps d = d export @@ -431,47 +431,47 @@ substNamesClause = substNamesClause' False mutual export substLoc : FC -> RawImp -> RawImp - substLoc fc' (IVar fc n) = IVar fc' n - substLoc fc' (IPi fc r p mn argTy retTy) - = IPi fc' r p mn (substLoc fc' argTy) + substLoc fc' (Elaboratable_Name fc n) = Elaboratable_Name fc' n + substLoc fc' (Elaboratable_Dependent_Function_Type fc r p mn argTy retTy) + = Elaboratable_Dependent_Function_Type fc' r p mn (substLoc fc' argTy) (substLoc fc' retTy) - substLoc fc' (ILam fc r p mn argTy scope) - = ILam fc' r p mn (substLoc fc' argTy) + substLoc fc' (Elaboratable_Lambda fc r p mn argTy scope) + = Elaboratable_Lambda fc' r p mn (substLoc fc' argTy) (substLoc fc' scope) - substLoc fc' (ILet fc lhsFC r n nTy nVal scope) - = ILet fc' fc' r n (substLoc fc' nTy) + substLoc fc' (Elaboratable_Binding fc lhsFC r n nTy nVal scope) + = Elaboratable_Binding fc' fc' r n (substLoc fc' nTy) (substLoc fc' nVal) (substLoc fc' scope) - substLoc fc' (ICase fc opts y ty xs) - = ICase fc' opts (substLoc fc' y) (substLoc fc' ty) + substLoc fc' (Elaboratable_Case fc opts y ty xs) + = Elaboratable_Case fc' opts (substLoc fc' y) (substLoc fc' ty) (map (substLocClause fc') xs) - substLoc fc' (ILocal fc xs y) - = ILocal fc' (map (substLocDecl fc') xs) + substLoc fc' (Elaboratable_Local_Definitions fc xs y) + = Elaboratable_Local_Definitions fc' (map (substLocDecl fc') xs) (substLoc fc' y) - substLoc fc' (IApp fc fn arg) - = IApp fc' (substLoc fc' fn) (substLoc fc' arg) - substLoc fc' (INamedApp fc fn y arg) - = INamedApp fc' (substLoc fc' fn) y (substLoc fc' arg) - substLoc fc' (IAutoApp fc fn arg) - = IAutoApp fc' (substLoc fc' fn) (substLoc fc' arg) - substLoc fc' (IWithApp fc fn arg) - = IWithApp fc' (substLoc fc' fn) (substLoc fc' arg) - substLoc fc' (IAlternative fc y xs) - = IAlternative fc' y (map (substLoc fc') xs) - substLoc fc' (ICoerced fc y) - = ICoerced fc' (substLoc fc' y) - substLoc fc' (IAs fc nameFC s y pattern) - = IAs fc' fc' s y (substLoc fc' pattern) - substLoc fc' (IMustUnify fc r pattern) - = IMustUnify fc' r (substLoc fc' pattern) - substLoc fc' (IDelayed fc r t) - = IDelayed fc' r (substLoc fc' t) - substLoc fc' (IDelay fc t) - = IDelay fc' (substLoc fc' t) - substLoc fc' (IForce fc t) - = IForce fc' (substLoc fc' t) - substLoc fc' (IUpdate fc updates tm) - = IUpdate fc' (map (mapFieldUpdateTerm $ substLoc fc') updates) + substLoc fc' (Elaboratable_Apply fc fn arg) + = Elaboratable_Apply fc' (substLoc fc' fn) (substLoc fc' arg) + substLoc fc' (Elaboratable_Named_Apply fc fn y arg) + = Elaboratable_Named_Apply fc' (substLoc fc' fn) y (substLoc fc' arg) + substLoc fc' (Elaboratable_Automatic_Apply fc fn arg) + = Elaboratable_Automatic_Apply fc' (substLoc fc' fn) (substLoc fc' arg) + substLoc fc' (Elaboratable_With_Apply fc fn arg) + = Elaboratable_With_Apply fc' (substLoc fc' fn) (substLoc fc' arg) + substLoc fc' (Elaboratable_Alternative fc y xs) + = Elaboratable_Alternative fc' y (map (substLoc fc') xs) + substLoc fc' (Elaboratable_Coerced fc y) + = Elaboratable_Coerced fc' (substLoc fc' y) + substLoc fc' (Elaboratable_As_Pattern fc nameFC s y pattern) + = Elaboratable_As_Pattern fc' fc' s y (substLoc fc' pattern) + substLoc fc' (Elaboratable_Must_Unify fc r pattern) + = Elaboratable_Must_Unify fc' r (substLoc fc' pattern) + substLoc fc' (Elaboratable_Delayed_Type fc r t) + = Elaboratable_Delayed_Type fc' r (substLoc fc' t) + substLoc fc' (Elaboratable_Delay fc t) + = Elaboratable_Delay fc' (substLoc fc' t) + substLoc fc' (Elaboratable_Force fc t) + = Elaboratable_Force fc' (substLoc fc' t) + substLoc fc' (Elaboratable_Record_Update fc updates tm) + = Elaboratable_Record_Update fc' (map (mapFieldUpdateTerm $ substLoc fc') updates) (substLoc fc' tm) substLoc fc' tm = tm @@ -497,16 +497,16 @@ mutual = MkImpLater fc' n (substLoc fc' con) substLocDecl : FC -> ImpDecl -> ImpDecl - substLocDecl fc' (IClaim (MkWithData _ $ MkIClaimData r vis opts td)) - = IClaim (MkFCVal fc' $ MkIClaimData r vis opts (map (substLoc fc') (set "fc" fc' td))) - substLocDecl fc' (IDef fc n cs) - = IDef fc' n (map (substLocClause fc') cs) - substLocDecl fc' (IData fc vis mbtot d) - = IData fc' vis mbtot (substLocData fc' d) - substLocDecl fc' (IFail fc msg ds) - = IFail fc' msg (map (substLocDecl fc') ds) - substLocDecl fc' (INamespace fc ns ds) - = INamespace fc' ns (map (substLocDecl fc') ds) + substLocDecl fc' (Elaboratable_Claim (MkWithData _ $ Make_Elaboratable_Claim_Data r vis opts td)) + = Elaboratable_Claim (MkFCVal fc' $ Make_Elaboratable_Claim_Data r vis opts (map (substLoc fc') (set "fc" fc' td))) + substLocDecl fc' (Elaboratable_Definition fc n cs) + = Elaboratable_Definition fc' n (map (substLocClause fc') cs) + substLocDecl fc' (Elaboratable_Data_Declaration fc vis mbtot d) + = Elaboratable_Data_Declaration fc' vis mbtot (substLocData fc' d) + substLocDecl fc' (Elaboratable_Expected_Failure fc msg ds) + = Elaboratable_Expected_Failure fc' msg (map (substLocDecl fc') ds) + substLocDecl fc' (Elaboratable_Namespace_Block fc ns ds) + = Elaboratable_Namespace_Block fc' ns (map (substLocDecl fc') ds) substLocDecl fc' d = d nameNum : String -> (String, Maybe Int) @@ -681,13 +681,13 @@ etaExpandImplicits fc ty lhs rhs pure (apply lhs lhsArgs, apply rhs rhsArgs) where collectImplicits : RawImp -> List Name - collectImplicits (IPi _ _ Explicit _ _ ty) = [] - collectImplicits (IPi _ _ _ (Just n) _ ty) = n :: collectImplicits ty + collectImplicits (Elaboratable_Dependent_Function_Type _ _ Explicit _ _ ty) = [] + collectImplicits (Elaboratable_Dependent_Function_Type _ _ _ (Just n) _ ty) = n :: collectImplicits ty collectImplicits _ = [] ivar : (bind : Bool) -> Name -> RawImp - ivar True = IBindVar fc - ivar False = IVar fc + ivar True = Elaboratable_Bind_Name fc + ivar False = Elaboratable_Name fc makeArg : (bind : Bool) -> (Name, Name) -> Arg makeArg bind (n, bindName) = Named fc n $ ivar bind bindName diff --git a/TTImp/WithClause.idr b/TTImp/WithClause.idr index 385333da90..67e8d72615 100644 --- a/TTImp/WithClause.idr +++ b/TTImp/WithClause.idr @@ -15,11 +15,11 @@ matchFail loc = throw (GenericMsg loc "With clause does not match parent") --- To be used on the lhs of a nested with clause to figure out a tight location --- information to give to the generated LHS getHeadLoc : RawImp -> Core FC -getHeadLoc (IVar fc _) = pure fc -getHeadLoc (IApp _ f _) = getHeadLoc f -getHeadLoc (IWithApp _ f _) = getHeadLoc f -getHeadLoc (IAutoApp _ f _) = getHeadLoc f -getHeadLoc (INamedApp _ f _ _) = getHeadLoc f +getHeadLoc (Elaboratable_Name fc _) = pure fc +getHeadLoc (Elaboratable_Apply _ f _) = getHeadLoc f +getHeadLoc (Elaboratable_With_Apply _ f _) = getHeadLoc f +getHeadLoc (Elaboratable_Automatic_Apply _ f _) = getHeadLoc f +getHeadLoc (Elaboratable_Named_Apply _ f _ _) = getHeadLoc f getHeadLoc t = throw (InternalError $ "Could not find head of LHS: " ++ show t) addAlias : {auto m : Ref MD Metadata} -> @@ -38,71 +38,71 @@ mutual {auto c : Ref Ctxt Defs} -> (lhs : Bool) -> RawImp -> RawImp -> Core (List (Name, RawImp)) - getMatch lhs (IBindVar to n) tm@(IBindVar from _) + getMatch lhs (Elaboratable_Bind_Name to n) tm@(Elaboratable_Bind_Name from _) = [(n, tm)] <$ addAlias from to - getMatch lhs (IBindVar _ n) tm = pure [(n, tm)] + getMatch lhs (Elaboratable_Bind_Name _ n) tm = pure [(n, tm)] getMatch lhs (Implicit {}) tm = pure [] - getMatch lhs _ (IMustUnify _ UserDotted _) = pure [] + getMatch lhs _ (Elaboratable_Must_Unify _ UserDotted _) = pure [] - getMatch lhs (IVar to (NS ns n)) (IVar from (NS ns' n')) + getMatch lhs (Elaboratable_Name to (NS ns n)) (Elaboratable_Name from (NS ns' n')) = if n == n' && isParentOf ns' ns then [] <$ addAlias from to -- <$ decorateName loc nm else matchFail from - getMatch lhs (IVar to (NS ns n)) (IVar from n') + getMatch lhs (Elaboratable_Name to (NS ns n)) (Elaboratable_Name from n') = if n == n' then [] <$ addAlias from to -- <$ decorateName loc (NS ns n') else matchFail from - getMatch lhs (IVar to n) (IVar from n') + getMatch lhs (Elaboratable_Name to n) (Elaboratable_Name from n') = if n == n' then [] <$ addAlias from to -- <$ decorateName loc n' else matchFail from - getMatch lhs (IPi _ c p n arg ret) (IPi loc c' p' n' arg' ret') + getMatch lhs (Elaboratable_Dependent_Function_Type _ c p n arg ret) (Elaboratable_Dependent_Function_Type loc c' p' n' arg' ret') = if c == c' && eqPiInfoBy (\_, _ => True) p p' && n == n' then matchAll lhs [(arg, arg'), (ret, ret')] else matchFail loc -- TODO: Lam, Let, Case, Local, Update - getMatch lhs (IApp _ f a) (IApp loc f' a') + getMatch lhs (Elaboratable_Apply _ f a) (Elaboratable_Apply loc f' a') = matchAll lhs [(f, f'), (a, a')] - getMatch lhs (IAutoApp _ f a) (IAutoApp loc f' a') + getMatch lhs (Elaboratable_Automatic_Apply _ f a) (Elaboratable_Automatic_Apply loc f' a') = matchAll lhs [(f, f'), (a, a')] - getMatch lhs (INamedApp _ f n a) (INamedApp loc f' n' a') + getMatch lhs (Elaboratable_Named_Apply _ f n a) (Elaboratable_Named_Apply loc f' n' a') = if n == n' then matchAll lhs [(f, f'), (a, a')] else matchFail loc - getMatch lhs (IWithApp _ f a) (IWithApp loc f' a') + getMatch lhs (Elaboratable_With_Apply _ f a) (Elaboratable_With_Apply loc f' a') = matchAll lhs [(f, f'), (a, a')] -- On LHS: If there's an implicit in the parent, but not the clause, add the -- implicit to the clause. This will propagate the implicit through to the -- body - getMatch True (INamedApp fc f n a) f' + getMatch True (Elaboratable_Named_Apply fc f n a) f' = matchAll True [(f, f'), (a, a)] - getMatch True (IAutoApp fc f a) f' + getMatch True (Elaboratable_Automatic_Apply fc f a) f' = matchAll True [(f, f'), (a, a)] -- On RHS: Rely on unification to fill in the implicit - getMatch False (INamedApp fc f n a) f' + getMatch False (Elaboratable_Named_Apply fc f n a) f' = getMatch False f f' - getMatch False (IAutoApp fc f a) f' + getMatch False (Elaboratable_Automatic_Apply fc f a) f' = getMatch False f f' -- Can't have an implicit in the clause if there wasn't a matching -- implicit in the parent - getMatch lhs f (INamedApp fc f' n a) + getMatch lhs f (Elaboratable_Named_Apply fc f' n a) = matchFail fc - getMatch lhs f (IAutoApp fc f' a) + getMatch lhs f (Elaboratable_Automatic_Apply fc f' a) = matchFail fc -- Alternatives are okay as long as the alternatives correspond, and -- one of them is okay - getMatch lhs (IAlternative _ _ as) (IAlternative fc _ as') + getMatch lhs (Elaboratable_Alternative _ _ as) (Elaboratable_Alternative fc _ as') = matchAny fc lhs (zip as as') - getMatch lhs (IAs _ _ _ nm@(UN (Basic _)) p) (IAs _ fc _ nm'@(UN (Basic _)) p') + getMatch lhs (Elaboratable_As_Pattern _ _ _ nm@(UN (Basic _)) p) (Elaboratable_As_Pattern _ fc _ nm'@(UN (Basic _)) p') = do ms <- getMatch lhs p p' - mergeMatches lhs ((nm, IAs fc emptyFC UseLeft nm' (Implicit fc True)) :: ms) - getMatch lhs (IAs _ _ _ nm@(UN (Basic _)) p) p' + mergeMatches lhs ((nm, Elaboratable_As_Pattern fc emptyFC UseLeft nm' (Implicit fc True)) :: ms) + getMatch lhs (Elaboratable_As_Pattern _ _ _ nm@(UN (Basic _)) p) p' = do ms <- getMatch lhs p p' mergeMatches lhs ((nm, p') :: ms) - getMatch lhs (IAs _ _ _ _ p) p' = getMatch lhs p p' - getMatch lhs p (IAs _ _ _ _ p') = getMatch lhs p p' - getMatch lhs (IType _) (IType _) = pure [] - getMatch lhs (IPrimVal fc c) (IPrimVal fc' c') = + getMatch lhs (Elaboratable_As_Pattern _ _ _ _ p) p' = getMatch lhs p p' + getMatch lhs p (Elaboratable_As_Pattern _ _ _ _ p') = getMatch lhs p p' + getMatch lhs (Elaboratable_Type_Universe _) (Elaboratable_Type_Universe _) = pure [] + getMatch lhs (Elaboratable_Primitive_Value fc c) (Elaboratable_Primitive_Value fc' c') = if c == c' then pure [] else matchFail fc' @@ -151,9 +151,9 @@ getArgMatch ploc mode True warg ms (Just (AutoImplicit, nm)) = case lookup nm ms of Just tm => tm Nothing => - let arg = ISearch ploc 500 in + let arg = Elaboratable_Search ploc 500 in if isJust (isLHS mode) - then IAs ploc ploc UseLeft nm arg + then Elaboratable_As_Pattern ploc ploc UseLeft nm arg else arg getArgMatch ploc mode search warg ms (Just (_, nm)) = case lookup nm ms of @@ -161,7 +161,7 @@ getArgMatch ploc mode search warg ms (Just (_, nm)) Nothing => let arg = Implicit ploc True in if isJust (isLHS mode) - then IAs ploc ploc UseLeft nm arg + then Elaboratable_As_Pattern ploc ploc UseLeft nm arg else arg export @@ -196,17 +196,17 @@ getNewLHS iploc drop nest wname wargnames lhs_raw patlhs log "declare.def.clause.with" 5 $ "Parameters: " ++ show params hdloc <- getHeadLoc patlhs - let newlhs = apply (IVar hdloc wname) (params ++ rest) + let newlhs = apply (Elaboratable_Name hdloc wname) (params ++ rest) log "declare.def.clause.with" 5 $ "New LHS: " ++ show newlhs pure newlhs where dropWithArgs : Nat -> RawImp -> Core (RawImp, List RawImp) dropWithArgs Z tm = pure (tm, []) - dropWithArgs (S k) (IApp _ f arg) + dropWithArgs (S k) (Elaboratable_Apply _ f arg) = do (tm, rest) <- dropWithArgs k f pure (tm, arg :: rest) - dropWithArgs (S k) (IWithApp _ f arg) + dropWithArgs (S k) (Elaboratable_With_Apply _ f arg) = do (tm, rest) <- dropWithArgs k f pure (tm, arg :: rest) -- Shouldn't happen if parsed correctly, but there's no guarantee that @@ -225,10 +225,10 @@ withRHS fc drop wname wargnames tm toplhs where withApply : FC -> RawImp -> List RawImp -> RawImp withApply fc f [] = f - withApply fc f (a :: as) = withApply fc (IWithApp fc f a) as + withApply fc f (a :: as) = withApply fc (Elaboratable_With_Apply fc f a) as updateWith : FC -> RawImp -> List RawImp -> Core RawImp - updateWith fc (IWithApp _ f a) ws = updateWith fc f (a :: ws) + updateWith fc (Elaboratable_With_Apply _ f a) ws = updateWith fc f (a :: ws) updateWith fc tm [] = throw (GenericMsg fc "Badly formed 'with' application") updateWith fc tm (arg :: args) @@ -236,7 +236,7 @@ withRHS fc drop wname wargnames tm toplhs ms <- getMatch False toplhs tm hdloc <- getHeadLoc tm log "declare.def.clause.with" 10 $ "Result: " ++ show ms - let newrhs = apply (IVar hdloc wname) + let newrhs = apply (Elaboratable_Name hdloc wname) (map (getArgMatch fc InExpr True arg ms) wargnames) log "declare.def.clause.with" 10 $ "With args for RHS: " ++ show wargnames log "declare.def.clause.with" 10 $ "New RHS: " ++ show newrhs @@ -244,29 +244,29 @@ withRHS fc drop wname wargnames tm toplhs mutual wrhs : RawImp -> Core RawImp - wrhs (IPi fc c p n ty sc) - = pure $ IPi fc c p n !(wrhs ty) !(wrhs sc) - wrhs (ILam fc c p n ty sc) - = pure $ ILam fc c p n !(wrhs ty) !(wrhs sc) - wrhs (ILet fc lhsFC c n ty val sc) - = pure $ ILet fc lhsFC c n !(wrhs ty) !(wrhs val) !(wrhs sc) - wrhs (ICase fc opts sc ty clauses) - = pure $ ICase fc opts !(wrhs sc) !(wrhs ty) !(traverse wrhsC clauses) - wrhs (ILocal fc decls sc) - = pure $ ILocal fc decls !(wrhs sc) -- TODO! - wrhs (IUpdate fc upds tm) - = pure $ IUpdate fc upds !(wrhs tm) -- TODO! - wrhs (IApp fc f a) - = pure $ IApp fc !(wrhs f) !(wrhs a) - wrhs (IAutoApp fc f a) - = pure $ IAutoApp fc !(wrhs f) !(wrhs a) - wrhs (INamedApp fc f n a) - = pure $ INamedApp fc !(wrhs f) n !(wrhs a) - wrhs (IWithApp fc f a) = updateWith fc f [a] - wrhs (IRewrite fc rule tm) = pure $ IRewrite fc !(wrhs rule) !(wrhs tm) - wrhs (IDelayed fc r tm) = pure $ IDelayed fc r !(wrhs tm) - wrhs (IDelay fc tm) = pure $ IDelay fc !(wrhs tm) - wrhs (IForce fc tm) = pure $ IForce fc !(wrhs tm) + wrhs (Elaboratable_Dependent_Function_Type fc c p n ty sc) + = pure $ Elaboratable_Dependent_Function_Type fc c p n !(wrhs ty) !(wrhs sc) + wrhs (Elaboratable_Lambda fc c p n ty sc) + = pure $ Elaboratable_Lambda fc c p n !(wrhs ty) !(wrhs sc) + wrhs (Elaboratable_Binding fc lhsFC c n ty val sc) + = pure $ Elaboratable_Binding fc lhsFC c n !(wrhs ty) !(wrhs val) !(wrhs sc) + wrhs (Elaboratable_Case fc opts sc ty clauses) + = pure $ Elaboratable_Case fc opts !(wrhs sc) !(wrhs ty) !(traverse wrhsC clauses) + wrhs (Elaboratable_Local_Definitions fc decls sc) + = pure $ Elaboratable_Local_Definitions fc decls !(wrhs sc) -- TODO! + wrhs (Elaboratable_Record_Update fc upds tm) + = pure $ Elaboratable_Record_Update fc upds !(wrhs tm) -- TODO! + wrhs (Elaboratable_Apply fc f a) + = pure $ Elaboratable_Apply fc !(wrhs f) !(wrhs a) + wrhs (Elaboratable_Automatic_Apply fc f a) + = pure $ Elaboratable_Automatic_Apply fc !(wrhs f) !(wrhs a) + wrhs (Elaboratable_Named_Apply fc f n a) + = pure $ Elaboratable_Named_Apply fc !(wrhs f) n !(wrhs a) + wrhs (Elaboratable_With_Apply fc f a) = updateWith fc f [a] + wrhs (Elaboratable_Rewrite fc rule tm) = pure $ Elaboratable_Rewrite fc !(wrhs rule) !(wrhs tm) + wrhs (Elaboratable_Delayed_Type fc r tm) = pure $ Elaboratable_Delayed_Type fc r !(wrhs tm) + wrhs (Elaboratable_Delay fc tm) = pure $ Elaboratable_Delay fc !(wrhs tm) + wrhs (Elaboratable_Force fc tm) = pure $ Elaboratable_Force fc !(wrhs tm) wrhs tm = pure tm wrhsC : ImpClause -> Core ImpClause diff --git a/Yaffle/REPL.idr b/Yaffle/REPL.idr index 03a4f68585..de8590edde 100644 --- a/Yaffle/REPL.idr +++ b/Yaffle/REPL.idr @@ -41,7 +41,7 @@ process (Eval ttimp) tmnf <- normalise defs Env.empty tm coreLift_ (printLn !(unelab Env.empty tmnf)) pure True -process (Check (IVar _ n)) +process (Check (Elaboratable_Name _ n)) = do defs <- get Ctxt ns <- lookupTyName n (gamma defs) traverse_ printName ns From 8ed2d93b202b35aeed9971c6b4327ecf78ae381d Mon Sep 17 00:00:00 2001 From: i Date: Tue, 1 Sep 2026 23:02:47 -0400 Subject: [PATCH 09/80] Spell out administrative-normal-form vocabulary (#66) Spell out the compiler-internal administrative-normal-form datatype, constructors, alternatives, definitions, and conversion helpers. Correct the TTImp spelling from Elaboratable to Elaborable while preserving the Compiler.ANF module path, public reflection compatibility names, and checked-in bootstrap output. Validated by both clean-commit compiler builds, source-layout checks, the self-hosting bootstrap, and edric001-edric006 plus edric009. --- ANF_READABLE_NAMES.md | 54 ++ Compiler/ANF.idr | 338 ++++++------ Compiler/Common.idr | 22 +- Compiler/RefC/RefC.idr | 98 ++-- Compiler/VMCode.idr | 56 +- Core/Options.idr | 2 +- Idris/CommandLine.idr | 4 +- Idris/Desugar.idr | 300 +++++------ Idris/Elab/Implementation.idr | 86 ++-- Idris/Elab/Interface.idr | 96 ++-- Idris/REPL.idr | 12 +- Idris/Resugar.idr | 118 ++--- Idris/Syntax.idr | 2 +- TTIMP_READABLE_NAMES.md | 134 ++--- TTImp/BindImplicits.idr | 140 ++--- TTImp/Elab.idr | 6 +- TTImp/Elab/Ambiguity.idr | 74 +-- TTImp/Elab/App.idr | 66 +-- TTImp/Elab/Binders.idr | 2 +- TTImp/Elab/Case.idr | 40 +- TTImp/Elab/ImplicitBind.idr | 2 +- TTImp/Elab/Local.idr | 46 +- TTImp/Elab/Quote.idr | 120 ++--- TTImp/Elab/Record.idr | 30 +- TTImp/Elab/Rewrite.idr | 6 +- TTImp/Elab/Term.idr | 108 ++-- TTImp/Impossible.idr | 38 +- TTImp/Interactive/CaseSplit.idr | 56 +- TTImp/Interactive/ExprSearch.idr | 2 +- TTImp/Interactive/GenerateDef.idr | 50 +- TTImp/Interactive/Intro.idr | 8 +- TTImp/Interactive/MakeLemma.idr | 6 +- TTImp/Parser.idr | 102 ++-- TTImp/PartialEval.idr | 42 +- TTImp/ProcessData.idr | 20 +- TTImp/ProcessDecls.idr | 32 +- TTImp/ProcessDef.idr | 24 +- TTImp/ProcessParams.idr | 6 +- TTImp/ProcessRecord.idr | 58 +-- TTImp/ProcessType.idr | 6 +- TTImp/Reflect.idr | 192 +++---- TTImp/TTImp.idr | 544 ++++++++++---------- TTImp/TTImp/Functor.idr | 184 +++---- TTImp/TTImp/TTC.idr | 188 +++---- TTImp/TTImp/Traversals.idr | 108 ++-- TTImp/Unelab.idr | 84 +-- TTImp/Utils.idr | 384 +++++++------- TTImp/WithClause.idr | 124 ++--- Yaffle/REPL.idr | 2 +- _/docs/source/backends/backend-cookbook.rst | 18 +- 50 files changed, 2147 insertions(+), 2093 deletions(-) create mode 100644 ANF_READABLE_NAMES.md diff --git a/ANF_READABLE_NAMES.md b/ANF_READABLE_NAMES.md new file mode 100644 index 0000000000..bb9815c537 --- /dev/null +++ b/ANF_READABLE_NAMES.md @@ -0,0 +1,54 @@ +# Readable administrative-normal-form names + +The `A` at the beginning of these compiler constructors marked the administrative-normal-form layer. This branch spells out that layer instead of requiring the reader to remember the initial. + +The module path remains `Compiler.ANF`, which is the conventional short name for the compiler pass. The datatype and the terms being read inside the module use complete names. + +## Main expression vocabulary + +| Old name | Readable name | +|---|---| +| `ANF` | `Administrative_Normal_Form` | +| `AVar` | `Administrative_Normal_Form_Variable` | +| `ALocal` | `Administrative_Normal_Form_Local_Variable` | +| `ANull` | `Administrative_Normal_Form_Erased_Variable` | +| `AV` | `Administrative_Normal_Form_Variable_Expression` | +| `AAppName` | `Administrative_Normal_Form_Named_Function_Application` | +| `AUnderApp` | `Administrative_Normal_Form_Partial_Application` | +| `AApp` | `Administrative_Normal_Form_Closure_Application` | +| `ALet` | `Administrative_Normal_Form_Binding` | +| `ACon` | `Administrative_Normal_Form_Constructor_Value` | +| `AOp` | `Administrative_Normal_Form_Primitive_Operation` | +| `AExtPrim` | `Administrative_Normal_Form_External_Primitive` | +| `AConCase` | `Administrative_Normal_Form_Constructor_Case` | +| `AConstCase` | `Administrative_Normal_Form_Constant_Case` | +| `APrimVal` | `Administrative_Normal_Form_Primitive_Value` | +| `AErased` | `Administrative_Normal_Form_Erased_Value` | +| `ACrash` | `Administrative_Normal_Form_Crash` | + +## Case alternatives and definitions + +| Old name | Readable name | +|---|---| +| `AConAlt` | `Administrative_Normal_Form_Constructor_Alternative` | +| `MkAConAlt` | `Make_Administrative_Normal_Form_Constructor_Alternative` | +| `AConstAlt` | `Administrative_Normal_Form_Constant_Alternative` | +| `MkAConstAlt` | `Make_Administrative_Normal_Form_Constant_Alternative` | +| `ANFDef` | `Administrative_Normal_Form_Definition` | +| `MkAFun` | `Make_Administrative_Normal_Form_Function` | +| `MkACon` | `Make_Administrative_Normal_Form_Constructor` | +| `MkAForeign` | `Make_Administrative_Normal_Form_Foreign_Function` | +| `MkAError` | `Make_Administrative_Normal_Form_Error` | + +## Nearby helper names + +| Old name | Readable name | +|---|---| +| `AVars` | `Administrative_Normal_Form_Variable_Environment` | +| `toANF` | `to_administrative_normal_form` | +| `anf` | `convert_expression_to_administrative_normal_form` | +| `anfArgs` | `convert_arguments_to_administrative_normal_form` | +| `anfConAlt` | `convert_constructor_alternative_to_administrative_normal_form` | +| `anfConstAlt` | `convert_constant_alternative_to_administrative_normal_form` | + +The earlier TTImp names also use `Elaborable_` now, replacing the awkward `Elaboratable_` spelling. diff --git a/Compiler/ANF.idr b/Compiler/ANF.idr index e5b25a3d75..6febcf2b92 100644 --- a/Compiler/ANF.idr +++ b/Compiler/ANF.idr @@ -10,106 +10,106 @@ import Data.Vect %default covering --- Convert the lambda lifted form to ANF, with variable names made explicit. +-- Convert the lambda lifted form to Administrative_Normal_Form, with variable names made explicit. -- i.e. turn intermediate expressions into let bindings. Every argument is -- a variable as a result. mutual public export - data AVar : Type where - ALocal : Int -> AVar - ANull : AVar + data Administrative_Normal_Form_Variable : Type where + Administrative_Normal_Form_Local_Variable : Int -> Administrative_Normal_Form_Variable + Administrative_Normal_Form_Erased_Variable : Administrative_Normal_Form_Variable public export - data ANF : Type where - AV : FC -> AVar -> ANF - AAppName : FC -> (lazy : Maybe LazyReason) -> Name -> List AVar -> ANF - AUnderApp : FC -> Name -> (missing : Nat) -> (args : List AVar) -> ANF - AApp : FC -> (lazy : Maybe LazyReason) -> (closure : AVar) -> (arg : AVar) -> ANF - ALet : FC -> (var : Int) -> ANF -> ANF -> ANF - ACon : FC -> Name -> ConInfo -> (tag : Maybe Int) -> List AVar -> ANF - AOp : {0 arity : Nat} -> FC -> (lazy : Maybe LazyReason) -> PrimFn arity -> Vect arity AVar -> ANF + data Administrative_Normal_Form : Type where + Administrative_Normal_Form_Variable_Expression : FC -> Administrative_Normal_Form_Variable -> Administrative_Normal_Form + Administrative_Normal_Form_Named_Function_Application : FC -> (lazy : Maybe LazyReason) -> Name -> List Administrative_Normal_Form_Variable -> Administrative_Normal_Form + Administrative_Normal_Form_Partial_Application : FC -> Name -> (missing : Nat) -> (args : List Administrative_Normal_Form_Variable) -> Administrative_Normal_Form + Administrative_Normal_Form_Closure_Application : FC -> (lazy : Maybe LazyReason) -> (closure : Administrative_Normal_Form_Variable) -> (arg : Administrative_Normal_Form_Variable) -> Administrative_Normal_Form + Administrative_Normal_Form_Binding : FC -> (var : Int) -> Administrative_Normal_Form -> Administrative_Normal_Form -> Administrative_Normal_Form + Administrative_Normal_Form_Constructor_Value : FC -> Name -> ConInfo -> (tag : Maybe Int) -> List Administrative_Normal_Form_Variable -> Administrative_Normal_Form + Administrative_Normal_Form_Primitive_Operation : {0 arity : Nat} -> FC -> (lazy : Maybe LazyReason) -> PrimFn arity -> Vect arity Administrative_Normal_Form_Variable -> Administrative_Normal_Form -- ^ we explicitly bind arity here to silence the warning that it shadows -- existing functions called arity. - AExtPrim : FC -> (lazy : Maybe LazyReason) -> Name -> List AVar -> ANF - AConCase : FC -> AVar -> List AConAlt -> Maybe ANF -> ANF - AConstCase : FC -> AVar -> List AConstAlt -> Maybe ANF -> ANF - APrimVal : FC -> Constant -> ANF - AErased : FC -> ANF - ACrash : FC -> String -> ANF + Administrative_Normal_Form_External_Primitive : FC -> (lazy : Maybe LazyReason) -> Name -> List Administrative_Normal_Form_Variable -> Administrative_Normal_Form + Administrative_Normal_Form_Constructor_Case : FC -> Administrative_Normal_Form_Variable -> List Administrative_Normal_Form_Constructor_Alternative -> Maybe Administrative_Normal_Form -> Administrative_Normal_Form + Administrative_Normal_Form_Constant_Case : FC -> Administrative_Normal_Form_Variable -> List Administrative_Normal_Form_Constant_Alternative -> Maybe Administrative_Normal_Form -> Administrative_Normal_Form + Administrative_Normal_Form_Primitive_Value : FC -> Constant -> Administrative_Normal_Form + Administrative_Normal_Form_Erased_Value : FC -> Administrative_Normal_Form + Administrative_Normal_Form_Crash : FC -> String -> Administrative_Normal_Form public export - data AConAlt : Type where - MkAConAlt : Name -> ConInfo -> (tag : Maybe Int) -> (args : List Int) -> - ANF -> AConAlt + data Administrative_Normal_Form_Constructor_Alternative : Type where + Make_Administrative_Normal_Form_Constructor_Alternative : Name -> ConInfo -> (tag : Maybe Int) -> (args : List Int) -> + Administrative_Normal_Form -> Administrative_Normal_Form_Constructor_Alternative public export - data AConstAlt : Type where - MkAConstAlt : Constant -> ANF -> AConstAlt + data Administrative_Normal_Form_Constant_Alternative : Type where + Make_Administrative_Normal_Form_Constant_Alternative : Constant -> Administrative_Normal_Form -> Administrative_Normal_Form_Constant_Alternative public export -data ANFDef : Type where - MkAFun : (args : List Int) -> ANF -> ANFDef - MkACon : (tag : Maybe Int) -> (arity : Nat) -> (nt : Maybe Nat) -> ANFDef - MkAForeign : (ccs : List String) -> (fargs : List CFType) -> - CFType -> ANFDef - MkAError : ANF -> ANFDef +data Administrative_Normal_Form_Definition : Type where + Make_Administrative_Normal_Form_Function : (args : List Int) -> Administrative_Normal_Form -> Administrative_Normal_Form_Definition + Make_Administrative_Normal_Form_Constructor : (tag : Maybe Int) -> (arity : Nat) -> (nt : Maybe Nat) -> Administrative_Normal_Form_Definition + Make_Administrative_Normal_Form_Foreign_Function : (ccs : List String) -> (fargs : List CFType) -> + CFType -> Administrative_Normal_Form_Definition + Make_Administrative_Normal_Form_Error : Administrative_Normal_Form -> Administrative_Normal_Form_Definition showLazy : Maybe LazyReason -> String showLazy = maybe "" $ (" " ++) . show mutual export - Show AVar where - show (ALocal i) = "v" ++ show i - show ANull = "[__]" + Show Administrative_Normal_Form_Variable where + show (Administrative_Normal_Form_Local_Variable i) = "v" ++ show i + show Administrative_Normal_Form_Erased_Variable = "[__]" export - Eq AVar where - (ALocal i1) == (ALocal i2) = i1 == i2 - ANull == ANull = True + Eq Administrative_Normal_Form_Variable where + (Administrative_Normal_Form_Local_Variable i1) == (Administrative_Normal_Form_Local_Variable i2) = i1 == i2 + Administrative_Normal_Form_Erased_Variable == Administrative_Normal_Form_Erased_Variable = True _ == _ = False export - Ord AVar where - compare (ALocal i1) (ALocal i2) = compare i1 i2 - compare (ALocal _) ANull = GT - compare ANull (ALocal _) = LT - compare ANull ANull = EQ + Ord Administrative_Normal_Form_Variable where + compare (Administrative_Normal_Form_Local_Variable i1) (Administrative_Normal_Form_Local_Variable i2) = compare i1 i2 + compare (Administrative_Normal_Form_Local_Variable _) Administrative_Normal_Form_Erased_Variable = GT + compare Administrative_Normal_Form_Erased_Variable (Administrative_Normal_Form_Local_Variable _) = LT + compare Administrative_Normal_Form_Erased_Variable Administrative_Normal_Form_Erased_Variable = EQ export covering - Show ANF where - show (AV _ v) = show v - show (AAppName fc lazy n args) + Show Administrative_Normal_Form where + show (Administrative_Normal_Form_Variable_Expression _ v) = show v + show (Administrative_Normal_Form_Named_Function_Application fc lazy n args) = show n ++ showLazy lazy ++ "(" ++ showSep ", " (map show args) ++ ")" - show (AUnderApp fc n m args) + show (Administrative_Normal_Form_Partial_Application fc n m args) = "<" ++ show n ++ " underapp " ++ show m ++ ">(" ++ showSep ", " (map show args) ++ ")" - show (AApp fc lazy c arg) + show (Administrative_Normal_Form_Closure_Application fc lazy c arg) = show c ++ showLazy lazy ++ " @ (" ++ show arg ++ ")" - show (ALet fc x val sc) + show (Administrative_Normal_Form_Binding fc x val sc) = "%let v" ++ show x ++ " = (" ++ show val ++ ") in (" ++ show sc ++ ")" - show (ACon fc n _ t args) + show (Administrative_Normal_Form_Constructor_Value fc n _ t args) = "%con " ++ show n ++ "(" ++ showSep ", " (map show args) ++ ")" - show (AOp fc lazy op args) + show (Administrative_Normal_Form_Primitive_Operation fc lazy op args) = "%op " ++ show op ++ showLazy lazy ++ "(" ++ showSep ", " (toList (map show args)) ++ ")" - show (AExtPrim fc lazy p args) + show (Administrative_Normal_Form_External_Primitive fc lazy p args) = "%extprim " ++ show p ++ showLazy lazy ++ "(" ++ showSep ", " (map show args) ++ ")" - show (AConCase fc sc alts def) + show (Administrative_Normal_Form_Constructor_Case fc sc alts def) = "%case " ++ show sc ++ " of { " ++ showSep "| " (map show alts) ++ " " ++ show def ++ " }" - show (AConstCase fc sc alts def) + show (Administrative_Normal_Form_Constant_Case fc sc alts def) = "%case " ++ show sc ++ " of { " ++ showSep "| " (map show alts) ++ " " ++ show def ++ " }" - show (APrimVal _ x) = show x - show (AErased _) = "___" - show (ACrash _ x) = "%CRASH(" ++ show x ++ ")" + show (Administrative_Normal_Form_Primitive_Value _ x) = show x + show (Administrative_Normal_Form_Erased_Value _) = "___" + show (Administrative_Normal_Form_Crash _ x) = "%CRASH(" ++ show x ++ ")" export covering - Show AConAlt where - show (MkAConAlt n _ t args sc) + Show Administrative_Normal_Form_Constructor_Alternative where + show (Make_Administrative_Normal_Form_Constructor_Alternative n _ t args sc) = "%conalt " ++ show n ++ "(" ++ showSep ", " (map showArg args) ++ ") => " ++ show sc where @@ -118,23 +118,23 @@ mutual export covering - Show AConstAlt where - show (MkAConstAlt c sc) + Show Administrative_Normal_Form_Constant_Alternative where + show (Make_Administrative_Normal_Form_Constant_Alternative c sc) = "%constalt(" ++ show c ++ ") => " ++ show sc export covering -Show ANFDef where - show (MkAFun args exp) = show args ++ ": " ++ show exp - show (MkACon tag arity nt) +Show Administrative_Normal_Form_Definition where + show (Make_Administrative_Normal_Form_Function args exp) = show args ++ ": " ++ show exp + show (Make_Administrative_Normal_Form_Constructor tag arity nt) = "Constructor tag " ++ show tag ++ " arity " ++ show arity ++ " newtype by " ++ show nt - show (MkAForeign ccs args ret) + show (Make_Administrative_Normal_Form_Foreign_Function ccs args ret) = "Foreign call " ++ show ccs ++ " " ++ show args ++ " -> " ++ show ret - show (MkAError exp) = "Error: " ++ show exp + show (Make_Administrative_Normal_Form_Error exp) = "Error: " ++ show exp -AVars : Scope -> Type -AVars = All (\_ => Int) +Administrative_Normal_Form_Variable_Environment : Scope -> Type +Administrative_Normal_Form_Variable_Environment = All (\_ => Int) data Next : Type where @@ -145,182 +145,182 @@ nextVar put Next (i + 1) pure i -lookup : {idx : _} -> (0 p : IsVar x idx vs) -> AVars vs -> Int +lookup : {idx : _} -> (0 p : IsVar x idx vs) -> Administrative_Normal_Form_Variable_Environment vs -> Int lookup First (x :: xs) = x lookup (Later p) (x :: xs) = lookup p xs bindArgs : {auto v : Ref Next Int} -> - List ANF -> Core (List (AVar, Maybe ANF)) + List Administrative_Normal_Form -> Core (List (Administrative_Normal_Form_Variable, Maybe Administrative_Normal_Form)) bindArgs [] = pure [] -bindArgs (AV fc var :: xs) +bindArgs (Administrative_Normal_Form_Variable_Expression fc var :: xs) = do xs' <- bindArgs xs pure $ (var, Nothing) :: xs' -bindArgs (AErased fc :: xs) +bindArgs (Administrative_Normal_Form_Erased_Value fc :: xs) = do xs' <- bindArgs xs - pure $ (ANull, Nothing) :: xs' + pure $ (Administrative_Normal_Form_Erased_Variable, Nothing) :: xs' bindArgs (x :: xs) = do i <- nextVar xs' <- bindArgs xs - pure $ (ALocal i, Just x) :: xs' + pure $ (Administrative_Normal_Form_Local_Variable i, Just x) :: xs' letBind : {auto v : Ref Next Int} -> - FC -> List ANF -> (List AVar -> ANF) -> Core ANF + FC -> List Administrative_Normal_Form -> (List Administrative_Normal_Form_Variable -> Administrative_Normal_Form) -> Core Administrative_Normal_Form letBind fc args f = do bargs <- bindArgs args pure $ doBind [] bargs where - doBind : List AVar -> List (AVar, Maybe ANF) -> ANF + doBind : List Administrative_Normal_Form_Variable -> List (Administrative_Normal_Form_Variable, Maybe Administrative_Normal_Form) -> Administrative_Normal_Form doBind vs [] = f (reverse vs) - doBind vs ((ALocal i, Just t) :: xs) - = ALet fc i t (doBind (ALocal i :: vs) xs) + doBind vs ((Administrative_Normal_Form_Local_Variable i, Just t) :: xs) + = Administrative_Normal_Form_Binding fc i t (doBind (Administrative_Normal_Form_Local_Variable i :: vs) xs) doBind vs ((var, _) :: xs) = doBind (var :: vs) xs mlet : {auto v : Ref Next Int} -> - FC -> ANF -> (AVar -> ANF) -> Core ANF -mlet fc (AV _ var) sc = pure $ sc var + FC -> Administrative_Normal_Form -> (Administrative_Normal_Form_Variable -> Administrative_Normal_Form) -> Core Administrative_Normal_Form +mlet fc (Administrative_Normal_Form_Variable_Expression _ var) sc = pure $ sc var mlet fc val sc = do i <- nextVar - pure $ ALet fc i val (sc (ALocal i)) + pure $ Administrative_Normal_Form_Binding fc i val (sc (Administrative_Normal_Form_Local_Variable i)) mutual - anfArgs : {auto v : Ref Next Int} -> - FC -> AVars vars -> - List (Lifted vars) -> (List AVar -> ANF) -> Core ANF - anfArgs fc vs args f - = do args' <- traverse (anf vs) args + convert_arguments_to_administrative_normal_form : {auto v : Ref Next Int} -> + FC -> Administrative_Normal_Form_Variable_Environment vars -> + List (Lifted vars) -> (List Administrative_Normal_Form_Variable -> Administrative_Normal_Form) -> Core Administrative_Normal_Form + convert_arguments_to_administrative_normal_form fc vs args f + = do args' <- traverse (convert_expression_to_administrative_normal_form vs) args letBind fc args' f - anf : {auto v : Ref Next Int} -> - AVars vars -> Lifted vars -> Core ANF - anf vs (LLocal fc p) = pure $ AV fc (ALocal (lookup p vs)) - anf vs (LAppName fc lazy n args) - = anfArgs fc vs args (AAppName fc lazy n) - anf vs (LUnderApp fc n m args) - = anfArgs fc vs args (AUnderApp fc n m) - anf vs (LApp fc lazy f a) - = anfArgs fc vs [f, a] $ + convert_expression_to_administrative_normal_form : {auto v : Ref Next Int} -> + Administrative_Normal_Form_Variable_Environment vars -> Lifted vars -> Core Administrative_Normal_Form + convert_expression_to_administrative_normal_form vs (LLocal fc p) = pure $ Administrative_Normal_Form_Variable_Expression fc (Administrative_Normal_Form_Local_Variable (lookup p vs)) + convert_expression_to_administrative_normal_form vs (LAppName fc lazy n args) + = convert_arguments_to_administrative_normal_form fc vs args (Administrative_Normal_Form_Named_Function_Application fc lazy n) + convert_expression_to_administrative_normal_form vs (LUnderApp fc n m args) + = convert_arguments_to_administrative_normal_form fc vs args (Administrative_Normal_Form_Partial_Application fc n m) + convert_expression_to_administrative_normal_form vs (LApp fc lazy f a) + = convert_arguments_to_administrative_normal_form fc vs [f, a] $ \case - [fvar, avar] => AApp fc lazy fvar avar - _ => ACrash fc "Can't happen (AApp)" - anf vs (LLet fc x val sc) + [fvar, avar] => Administrative_Normal_Form_Closure_Application fc lazy fvar avar + _ => Administrative_Normal_Form_Crash fc "Can't happen (Administrative_Normal_Form_Closure_Application)" + convert_expression_to_administrative_normal_form vs (LLet fc x val sc) = do i <- nextVar let vs' = i :: vs - pure $ ALet fc i !(anf vs val) !(anf vs' sc) - anf vs (LCon fc n ci t args) - = anfArgs fc vs args (ACon fc n ci t) - anf vs (LOp {arity} fc lazy op args) - = do args' <- traverse (anf vs) (toList args) + pure $ Administrative_Normal_Form_Binding fc i !(convert_expression_to_administrative_normal_form vs val) !(convert_expression_to_administrative_normal_form vs' sc) + convert_expression_to_administrative_normal_form vs (LCon fc n ci t args) + = convert_arguments_to_administrative_normal_form fc vs args (Administrative_Normal_Form_Constructor_Value fc n ci t) + convert_expression_to_administrative_normal_form vs (LOp {arity} fc lazy op args) + = do args' <- traverse (convert_expression_to_administrative_normal_form vs) (toList args) letBind fc args' (\args => case toVect arity args of - Nothing => ACrash fc "Can't happen (AOp)" - Just argsv => AOp fc lazy op argsv) - anf vs (LExtPrim fc lazy p args) - = anfArgs fc vs args (AExtPrim fc lazy p) - anf vs (LConCase fc scr alts def) - = do scr' <- anf vs scr - alts' <- traverse (anfConAlt vs) alts - def' <- traverseOpt (anf vs) def - mlet fc scr' (\x => AConCase fc x alts' def') - anf vs (LConstCase fc scr alts def) - = do scr' <- anf vs scr - alts' <- traverse (anfConstAlt vs) alts - def' <- traverseOpt (anf vs) def - mlet fc scr' (\x => AConstCase fc x alts' def') - anf vs (LPrimVal fc c) = pure $ APrimVal fc c - anf vs (LErased fc) = pure $ AErased fc - anf vs (LCrash fc err) = pure $ ACrash fc err - - anfConAlt : {auto v : Ref Next Int} -> - AVars vars -> LiftedConAlt vars -> Core AConAlt - anfConAlt vs (MkLConAlt n ci t args sc) + Nothing => Administrative_Normal_Form_Crash fc "Can't happen (Administrative_Normal_Form_Primitive_Operation)" + Just argsv => Administrative_Normal_Form_Primitive_Operation fc lazy op argsv) + convert_expression_to_administrative_normal_form vs (LExtPrim fc lazy p args) + = convert_arguments_to_administrative_normal_form fc vs args (Administrative_Normal_Form_External_Primitive fc lazy p) + convert_expression_to_administrative_normal_form vs (LConCase fc scr alts def) + = do scr' <- convert_expression_to_administrative_normal_form vs scr + alts' <- traverse (convert_constructor_alternative_to_administrative_normal_form vs) alts + def' <- traverseOpt (convert_expression_to_administrative_normal_form vs) def + mlet fc scr' (\x => Administrative_Normal_Form_Constructor_Case fc x alts' def') + convert_expression_to_administrative_normal_form vs (LConstCase fc scr alts def) + = do scr' <- convert_expression_to_administrative_normal_form vs scr + alts' <- traverse (convert_constant_alternative_to_administrative_normal_form vs) alts + def' <- traverseOpt (convert_expression_to_administrative_normal_form vs) def + mlet fc scr' (\x => Administrative_Normal_Form_Constant_Case fc x alts' def') + convert_expression_to_administrative_normal_form vs (LPrimVal fc c) = pure $ Administrative_Normal_Form_Primitive_Value fc c + convert_expression_to_administrative_normal_form vs (LErased fc) = pure $ Administrative_Normal_Form_Erased_Value fc + convert_expression_to_administrative_normal_form vs (LCrash fc err) = pure $ Administrative_Normal_Form_Crash fc err + + convert_constructor_alternative_to_administrative_normal_form : {auto v : Ref Next Int} -> + Administrative_Normal_Form_Variable_Environment vars -> LiftedConAlt vars -> Core Administrative_Normal_Form_Constructor_Alternative + convert_constructor_alternative_to_administrative_normal_form vs (MkLConAlt n ci t args sc) = do (is, vs') <- bindArgs args vs - pure $ MkAConAlt n ci t is !(anf vs' sc) + pure $ Make_Administrative_Normal_Form_Constructor_Alternative n ci t is !(convert_expression_to_administrative_normal_form vs' sc) where - bindArgs : (args : List Name) -> AVars vars' -> - Core (List Int, AVars (args ++ vars')) + bindArgs : (args : List Name) -> Administrative_Normal_Form_Variable_Environment vars' -> + Core (List Int, Administrative_Normal_Form_Variable_Environment (args ++ vars')) bindArgs [] vs = pure ([], vs) bindArgs (n :: ns) vs = do i <- nextVar (is, vs') <- bindArgs ns vs pure (i :: is, i :: vs') - anfConstAlt : {auto v : Ref Next Int} -> - AVars vars -> LiftedConstAlt vars -> Core AConstAlt - anfConstAlt vs (MkLConstAlt c sc) - = pure $ MkAConstAlt c !(anf vs sc) + convert_constant_alternative_to_administrative_normal_form : {auto v : Ref Next Int} -> + Administrative_Normal_Form_Variable_Environment vars -> LiftedConstAlt vars -> Core Administrative_Normal_Form_Constant_Alternative + convert_constant_alternative_to_administrative_normal_form vs (MkLConstAlt c sc) + = pure $ Make_Administrative_Normal_Form_Constant_Alternative c !(convert_expression_to_administrative_normal_form vs sc) export -toANF : LiftedDef -> Core ANFDef -toANF (MkLFun args scope sc) +to_administrative_normal_form : LiftedDef -> Core Administrative_Normal_Form_Definition +to_administrative_normal_form (MkLFun args scope sc) = do v <- newRef Next (the Int 0) (iargs, vsNil) <- bindArgs args [] - let vs : AVars args = rewrite sym (appendNilRightNeutral args) in + let vs : Administrative_Normal_Form_Variable_Environment args = rewrite sym (appendNilRightNeutral args) in vsNil (iargs', vs) <- bindArgs scope vs - pure $ MkAFun (iargs ++ reverse iargs') !(anf vs sc) + pure $ Make_Administrative_Normal_Form_Function (iargs ++ reverse iargs') !(convert_expression_to_administrative_normal_form vs sc) where bindArgs : {auto v : Ref Next Int} -> - (args : List Name) -> AVars vars' -> - Core (List Int, AVars (args ++ vars')) + (args : List Name) -> Administrative_Normal_Form_Variable_Environment vars' -> + Core (List Int, Administrative_Normal_Form_Variable_Environment (args ++ vars')) bindArgs [] vs = pure ([], vs) bindArgs (n :: ns) vs = do i <- nextVar (is, vs') <- bindArgs ns vs pure (i :: is, i :: vs') -toANF (MkLCon t a ns) = pure $ MkACon t a ns -toANF (MkLForeign ccs fargs t) = pure $ MkAForeign ccs fargs t -toANF (MkLError err) +to_administrative_normal_form (MkLCon t a ns) = pure $ Make_Administrative_Normal_Form_Constructor t a ns +to_administrative_normal_form (MkLForeign ccs fargs t) = pure $ Make_Administrative_Normal_Form_Foreign_Function ccs fargs t +to_administrative_normal_form (MkLError err) = do v <- newRef Next (the Int 0) - pure $ MkAError !(anf [] err) + pure $ Make_Administrative_Normal_Form_Error !(convert_expression_to_administrative_normal_form [] err) export -freeVariables : ANF -> SortedSet AVar -freeVariables (AV _ x) = singleton x -freeVariables (AAppName _ _ n args) = fromList args -freeVariables (AUnderApp _ n _ args) = fromList args -freeVariables (AApp _ _ closure arg) = fromList [closure, arg] -freeVariables (ALet _ var value body) = - union (freeVariables value) (delete (ALocal var) $ freeVariables body) -freeVariables (ACon _ _ _ _ args) = fromList args -freeVariables (AOp _ _ _ args) = fromList $ toList args -freeVariables (AExtPrim _ _ _ args) = fromList args -freeVariables (AConCase _ sc alts mDef) = +freeVariables : Administrative_Normal_Form -> SortedSet Administrative_Normal_Form_Variable +freeVariables (Administrative_Normal_Form_Variable_Expression _ x) = singleton x +freeVariables (Administrative_Normal_Form_Named_Function_Application _ _ n args) = fromList args +freeVariables (Administrative_Normal_Form_Partial_Application _ n _ args) = fromList args +freeVariables (Administrative_Normal_Form_Closure_Application _ _ closure arg) = fromList [closure, arg] +freeVariables (Administrative_Normal_Form_Binding _ var value body) = + union (freeVariables value) (delete (Administrative_Normal_Form_Local_Variable var) $ freeVariables body) +freeVariables (Administrative_Normal_Form_Constructor_Value _ _ _ _ args) = fromList args +freeVariables (Administrative_Normal_Form_Primitive_Operation _ _ _ args) = fromList $ toList args +freeVariables (Administrative_Normal_Form_External_Primitive _ _ _ args) = fromList args +freeVariables (Administrative_Normal_Form_Constructor_Case _ sc alts mDef) = let altsAnf = - map (\(MkAConAlt _ _ _ args caseBody) => - difference (freeVariables caseBody) (fromList $ ALocal <$> args)) alts in - let vars : List (SortedSet AVar) = case mDef of + map (\(Make_Administrative_Normal_Form_Constructor_Alternative _ _ _ args caseBody) => + difference (freeVariables caseBody) (fromList $ Administrative_Normal_Form_Local_Variable <$> args)) alts in + let vars : List (SortedSet Administrative_Normal_Form_Variable) = case mDef of Just anf => freeVariables anf :: altsAnf Nothing => altsAnf in insert sc $ concat vars -freeVariables (AConstCase _ sc alts mDef) = - let altsAnf = map (\(MkAConstAlt _ caseBody) => caseBody) alts in - let anfs : List ANF = case mDef of +freeVariables (Administrative_Normal_Form_Constant_Case _ sc alts mDef) = + let altsAnf = map (\(Make_Administrative_Normal_Form_Constant_Alternative _ caseBody) => caseBody) alts in + let anfs : List Administrative_Normal_Form = case mDef of Just anf => anf :: altsAnf Nothing => altsAnf in insert sc $ foldMap freeVariables anfs freeVariables _ = empty export -usedConstructors : ANF -> SortedSet Name -usedConstructors (AV _ x) = empty -usedConstructors (AAppName _ _ n args) = empty -usedConstructors (AUnderApp _ n _ args) = empty -usedConstructors (AApp _ _ closure arg) = empty -usedConstructors (ALet _ var value body) = union (usedConstructors value) (usedConstructors body) -usedConstructors (ACon _ n _ _ args) = singleton n -usedConstructors (AOp _ _ _ args) = empty -usedConstructors (AExtPrim _ _ _ args) = empty -usedConstructors (AConCase _ sc alts mDef) = +usedConstructors : Administrative_Normal_Form -> SortedSet Name +usedConstructors (Administrative_Normal_Form_Variable_Expression _ x) = empty +usedConstructors (Administrative_Normal_Form_Named_Function_Application _ _ n args) = empty +usedConstructors (Administrative_Normal_Form_Partial_Application _ n _ args) = empty +usedConstructors (Administrative_Normal_Form_Closure_Application _ _ closure arg) = empty +usedConstructors (Administrative_Normal_Form_Binding _ var value body) = union (usedConstructors value) (usedConstructors body) +usedConstructors (Administrative_Normal_Form_Constructor_Value _ n _ _ args) = singleton n +usedConstructors (Administrative_Normal_Form_Primitive_Operation _ _ _ args) = empty +usedConstructors (Administrative_Normal_Form_External_Primitive _ _ _ args) = empty +usedConstructors (Administrative_Normal_Form_Constructor_Case _ sc alts mDef) = let altsAnf = - map (\(MkAConAlt _ _ _ args caseBody) => usedConstructors caseBody) alts in + map (\(Make_Administrative_Normal_Form_Constructor_Alternative _ _ _ args caseBody) => usedConstructors caseBody) alts in let anfs : List (SortedSet Name) = case mDef of Just anf => usedConstructors anf :: altsAnf Nothing => altsAnf in concat anfs -usedConstructors (AConstCase _ sc alts mDef) = - let altsAnf = map (\(MkAConstAlt _ caseBody) => caseBody) alts in - let anfs : List ANF = case mDef of +usedConstructors (Administrative_Normal_Form_Constant_Case _ sc alts mDef) = + let altsAnf = map (\(Make_Administrative_Normal_Form_Constant_Alternative _ caseBody) => caseBody) alts in + let anfs : List Administrative_Normal_Form = case mDef of Just anf => anf :: altsAnf Nothing => altsAnf in foldMap usedConstructors anfs diff --git a/Compiler/Common.idr b/Compiler/Common.idr index 66e271cf78..6a6c3d7d09 100644 --- a/Compiler/Common.idr +++ b/Compiler/Common.idr @@ -57,12 +57,12 @@ record Codegen where -- Say which phase of compilation is the last one to use - it saves time if -- you only ask for what you need. public export -data UsePhase = Cases | Lifted | ANF | VMCode +data UsePhase = Cases | Lifted | Administrative_Normal_Form | VMCode Eq UsePhase where (==) Cases Cases = True (==) Lifted Lifted = True - (==) ANF ANF = True + (==) Administrative_Normal_Form Administrative_Normal_Form = True (==) VMCode VMCode = True (==) _ _ = False @@ -72,7 +72,7 @@ Ord UsePhase where tag : UsePhase -> Int tag Cases = 0 tag Lifted = 1 - tag ANF = 2 + tag Administrative_Normal_Form = 2 tag VMCode = 3 public export @@ -89,8 +89,8 @@ record CompileData where -- ^ lambda lifted definitions, if required. Only the top level names -- will be in the context, and (for the moment...) I don't expect to -- need to look anything up, so it's just an alist. - anf : List (Name, ANFDef) - -- ^ lambda lifted and converted to ANF (all arguments to functions + anf : List (Name, Administrative_Normal_Form_Definition) + -- ^ lambda lifted and converted to Administrative_Normal_Form (all arguments to functions -- and constructors transformed to either variables or Null if erased) vmcode : List (Name, VMDef) -- ^ A much simplified virtual machine code, suitable for passing @@ -276,7 +276,7 @@ getCompileDataWith exports doLazyAnnots phase_in tm_in let phase = foldl {t=List} (flip $ maybe id max) phase_in $ [ Cases <$ dumpcases sopts , Lifted <$ dumplifted sopts - , ANF <$ dumpanf sopts + , Administrative_Normal_Form <$ dumpanf sopts , VMCode <$ dumpvmcode sopts ] @@ -355,8 +355,8 @@ getCompileDataWith exports doLazyAnnots phase_in tm_in let lifted = (mainname, MkLFun Scope.empty Scope.empty liftedtm) :: (ldefs ++ concat lifted_in) - anf <- if phase >= ANF - then logTime 2 "Get ANF" $ traverse (\ (n, d) => pure (n, !(toANF d))) lifted + anf <- if phase >= Administrative_Normal_Form + then logTime 2 "Get Administrative_Normal_Form" $ traverse (\ (n, d) => pure (n, !(to_administrative_normal_form d))) lifted else pure [] vmcode <- if phase >= VMCode then logTime 2 "Get VM Code" $ pure (allDefs anf) @@ -372,7 +372,7 @@ getCompileDataWith exports doLazyAnnots phase_in tm_in dumpIR f lifted whenJust (dumpanf sopts) $ \ f => - do coreLift $ putStrLn $ "Dumping ANF defs to " ++ f + do coreLift $ putStrLn $ "Dumping Administrative_Normal_Form defs to " ++ f dumpIR f anf whenJust (dumpvmcode sopts) $ \ f => @@ -441,8 +441,8 @@ getIncCompileData doLazyAnnots phase traverse (lambdaLift doLazyAnnots) cseDefs else pure [] let lifted = concat lifted_in - anf <- if phase >= ANF - then logTime 2 "Get ANF" $ traverse (\ (n, d) => pure (n, !(toANF d))) lifted + anf <- if phase >= Administrative_Normal_Form + then logTime 2 "Get Administrative_Normal_Form" $ traverse (\ (n, d) => pure (n, !(to_administrative_normal_form d))) lifted else pure [] vmcode <- if phase >= VMCode then logTime 2 "Get VM Code" $ pure (allDefs anf) diff --git a/Compiler/RefC/RefC.idr b/Compiler/RefC/RefC.idr index e06c2bc559..e2511de380 100644 --- a/Compiler/RefC/RefC.idr +++ b/Compiler/RefC/RefC.idr @@ -181,9 +181,9 @@ cOp BelieveMe [_, _, x] = "idris2_newReference(" ++ x ++ ")" cOp Crash [_, msg] = "idris2_crash(" ++ msg ++ ");" cOp fn args = show fn ++ "(" ++ (showSep ", " $ toList args) ++ ")" -varName : AVar -> String -varName (ALocal i) = "var_" ++ (show i) -varName (ANull) = "NULL" +varName : Administrative_Normal_Form_Variable -> String +varName (Administrative_Normal_Form_Local_Variable i) = "var_" ++ (show i) +varName (Administrative_Normal_Form_Erased_Variable) = "NULL" data ArgCounter : Type where data EnvTracker : Type where @@ -206,7 +206,7 @@ constantName = \case go x y = "idris2_constant_\{x}_\{y}" ReuseMap = SortedMap Name String -Owned = SortedSet AVar +Owned = SortedSet Administrative_Normal_Form_Variable ||| Environment for precise reference counting. ||| If variable borrowed (that is, it is not in the owned set) when used, call a function idris2_newReference. @@ -303,13 +303,13 @@ removeReuseConstructors : {auto oft : Ref OutfileText Output} -> Core () removeReuseConstructors = applyFunctionToVars "idris2_removeReuseConstructor" -avarToC : Env -> AVar -> String +avarToC : Env -> Administrative_Normal_Form_Variable -> String avarToC env var = if contains var env.owned then varName var -- case when the variable is borrowed else "idris2_newReference(" ++ varName var ++ ")" -avarsToC : Owned -> List AVar -> List String +avarsToC : Owned -> List Administrative_Normal_Form_Variable -> List String avarsToC _ [] = [] avarsToC owned (v::vars) = let v' = varName v in @@ -317,14 +317,14 @@ avarsToC owned (v::vars) = then v'::avarsToC (delete v owned) vars else "idris2_newReference(\{v'})"::avarsToC owned vars -- when v is borrowed -moveFromOwnedToBorrowed : Env -> SortedSet AVar -> Env +moveFromOwnedToBorrowed : Env -> SortedSet Administrative_Normal_Form_Variable -> Env moveFromOwnedToBorrowed env vars = { owned $= (`difference` vars) } env fillArgs : {auto oft : Ref OutfileText Output} -> {auto il : Ref IndentLevel Nat} -> Env -> String - -> List AVar + -> List Administrative_Normal_Form_Variable -> Nat -> Core () fillArgs _ _ [] _ = pure () @@ -339,7 +339,7 @@ makeClosure : {auto a : Ref ArgCounter Nat} -> {auto e : Ref EnvTracker Env} -> FC -> Name - -> List AVar + -> List Administrative_Normal_Form_Variable -> Nat -> Core String makeClosure fc n args missing = do @@ -355,9 +355,9 @@ makeClosure fc n args missing = do MaxExtractFunArgs : Nat MaxExtractFunArgs = 16 -integer_switch : List AConstAlt -> Bool +integer_switch : List Administrative_Normal_Form_Constant_Alternative -> Bool integer_switch [] = True -integer_switch (MkAConstAlt c _ :: _) = +integer_switch (Make_Administrative_Normal_Form_Constant_Alternative c _ :: _) = case c of (I x) => True (I8 x) => True @@ -401,7 +401,7 @@ dropUnusedReuseCons reuseMap usedCons = ||| The function takes as arguments the current owned vars and set vars that will be used. ||| Returns variables to remove and actual owned vars. -dropUnusedOwnedVars : Owned -> SortedSet AVar -> (List String, Owned) +dropUnusedOwnedVars : Owned -> SortedSet Administrative_Normal_Form_Variable -> (List String, Owned) dropUnusedOwnedVars owned usedVars = let actualOwned = intersection owned usedVars in let shouldDrop = difference owned actualOwned in @@ -453,7 +453,7 @@ mutual -> {auto il : Ref IndentLevel Nat} -> {auto _ : Ref ConstDef (SortedMap Constant ConstDef)} -> Env - -> String -> String -> List Int -> ANF -> TailPositionStatus + -> String -> String -> List Int -> Administrative_Normal_Form -> TailPositionStatus -> Core () concaseBody env returnvar expr args body tailPosition = do increaseIndentation @@ -475,12 +475,12 @@ mutual -> {auto il : Ref IndentLevel Nat} -> {auto e : Ref EnvTracker Env} -> {auto _ : Ref ConstDef (SortedMap Constant ConstDef)} - -> ANF + -> Administrative_Normal_Form -> TailPositionStatus -> Core String - cStatementsFromANF (AV fc x) _ = pure $ avarToC !(get EnvTracker) x - cStatementsFromANF (AAppName fc _ n args) tailPosition = do + cStatementsFromANF (Administrative_Normal_Form_Variable_Expression fc x) _ = pure $ avarToC !(get EnvTracker) x + cStatementsFromANF (Administrative_Normal_Form_Named_Function_Application fc _ n args) tailPosition = do let nargs = length args case tailPosition of InTailPosition => makeClosure fc n args 0 @@ -491,28 +491,28 @@ mutual let args' = avarsToC env.owned args pure "idris2_trampoline(\{cName n}(\{concat $ intersperse ", " args'}))" - cStatementsFromANF (AUnderApp fc n missing args) _ = makeClosure fc n args missing - cStatementsFromANF (AApp fc _ closure arg) tailPosition = do + cStatementsFromANF (Administrative_Normal_Form_Partial_Application fc n missing args) _ = makeClosure fc n args missing + cStatementsFromANF (Administrative_Normal_Form_Closure_Application fc _ closure arg) tailPosition = do env <- get EnvTracker pure $ (case tailPosition of NotInTailPosition => "idris2_apply_closure" InTailPosition => "idris2_tailcall_apply_closure") ++ "(\{avarToC env closure}, \{avarToC env arg})" - cStatementsFromANF (ALet fc var value body) tailPosition = do + cStatementsFromANF (Administrative_Normal_Form_Binding fc var value body) tailPosition = do env <- get EnvTracker let usedVars = freeVariables body - let borrowVal = intersection env.owned (delete (ALocal var) usedVars) - let owned' = if contains (ALocal var) usedVars then insert (ALocal var) borrowVal else borrowVal + let borrowVal = intersection env.owned (delete (Administrative_Normal_Form_Local_Variable var) usedVars) + let owned' = if contains (Administrative_Normal_Form_Local_Variable var) usedVars then insert (Administrative_Normal_Form_Local_Variable var) borrowVal else borrowVal let usedCons = usedConstructors value -- When translating value into C, we borrow variables that will be used in body let valueEnv = { reuseMap $= (`intersectionMap` usedCons) } (moveFromOwnedToBorrowed env borrowVal) put EnvTracker valueEnv emit fc $ "Idris2_Value * var_\{show var} = \{!(cStatementsFromANF value NotInTailPosition)};" - unless (contains (ALocal var) usedVars) $ emit fc $ "idris2_removeReference(var_\{show var});" + unless (contains (Administrative_Normal_Form_Local_Variable var) usedVars) $ emit fc $ "idris2_removeReference(var_\{show var});" put EnvTracker ({ owned := owned', reuseMap $= (`differenceMap` usedCons) } env) cStatementsFromANF body tailPosition - cStatementsFromANF (ACon fc n coninfo tag args) _ = do + cStatementsFromANF (Administrative_Normal_Form_Constructor_Value fc n coninfo tag args) _ = do if coninfo == NIL || coninfo == NOTHING || coninfo == ZERO || coninfo == UNIT then pure "(NULL /* \{show n} */)" else do @@ -538,9 +538,9 @@ mutual fillArgs env "\{constr}->args" args 0 pure "(Idris2_Value*)\{constr}" - cStatementsFromANF (AOp fc _ op args) _ = do + cStatementsFromANF (Administrative_Normal_Form_Primitive_Operation fc _ op args) _ = do let resultVar = "primVar_" ++ !(getNextCounter) - let argsVect : Env -> Vect ar AVar -> Vect ar String + let argsVect : Env -> Vect ar Administrative_Normal_Form_Variable -> Vect ar String argsVect _ [] = [] argsVect env (v :: vars) = let ownedVars = if contains v env.owned then singleton v else empty @@ -551,7 +551,7 @@ mutual removeVars $ toList $ map varName args pure resultVar - cStatementsFromANF (AExtPrim fc _ p args) _ = do + cStatementsFromANF (Administrative_Normal_Form_External_Primitive fc _ p args) _ = do let prims : List String = ["prim__newIORef", "prim__readIORef", "prim__writeIORef", "prim__newArray", "prim__arrayGet", "prim__arraySet", "prim__getField", "prim__setField", @@ -563,12 +563,12 @@ mutual emit fc $ "// call to external primitive " ++ cName p pure $ "idris2_\{cName p}("++ showSep ", " (map varName args) ++")" - cStatementsFromANF (AConCase fc sc alts mDef) tailPosition = do + cStatementsFromANF (Administrative_Normal_Form_Constructor_Case fc sc alts mDef) tailPosition = do let sc' = varName sc switchReturnVar <- getNewVarThatWillNotBeFreedAtEndOfBlock emit fc "Idris2_Value * \{switchReturnVar} = NULL;" env <- get EnvTracker - _ <- foldlC (\els, (MkAConAlt name coninfo tag args body) => do + _ <- foldlC (\els, (Make_Administrative_Normal_Form_Constructor_Alternative name coninfo tag args body) => do let erased = coninfo == NIL || coninfo == NOTHING || coninfo == ZERO || coninfo == UNIT if erased then emit emptyFC "\{els}if (NULL == \{sc'} /* \{show name} \{show coninfo} */) {" else if coninfo == CONS || coninfo == JUST || coninfo == SUCC @@ -578,7 +578,7 @@ mutual Nothing => emit emptyFC "\{els}if (! strcmp(((Idris2_Constructor *)\{sc'})->name, idris2_constr_\{cName name})) {" Just tag' => emit emptyFC "\{els}if (((Idris2_Constructor *)\{sc'})->tag == \{show tag'} /* \{show name} */) {" - let conArgs = ALocal <$> args + let conArgs = Administrative_Normal_Form_Local_Variable <$> args let ownedWithArgs = union (fromList conArgs) $ if erased then delete sc env.owned else env.owned let (shouldDrop, actualOwned) = dropUnusedOwnedVars ownedWithArgs (freeVariables body) let usedCons = usedConstructors body @@ -603,7 +603,7 @@ mutual emit emptyFC "}" pure switchReturnVar - cStatementsFromANF (AConstCase fc sc alts def) tailPosition = do + cStatementsFromANF (Administrative_Normal_Form_Constant_Case fc sc alts def) tailPosition = do let sc' = varName sc switchReturnVar <- getNewVarThatWillNotBeFreedAtEndOfBlock emit fc "Idris2_Value *\{switchReturnVar} = NULL;" @@ -612,18 +612,18 @@ mutual True => do tmpint <- getNewVarThatWillNotBeFreedAtEndOfBlock emit emptyFC "int64_t \{tmpint} = idris2_extractInt(\{sc'});" - _ <- foldlC (\els, (MkAConstAlt c body) => do + _ <- foldlC (\els, (Make_Administrative_Normal_Form_Constant_Alternative c body) => do emit emptyFC "\{els}if (\{tmpint} == \{const2Integer c 0}) {" concaseBody env switchReturnVar "" [] body tailPosition pure "} else ") "" alts pure () False => do - _ <- foldlC (\els, (MkAConstAlt c body) => do + _ <- foldlC (\els, (Make_Administrative_Normal_Form_Constant_Alternative c body) => do case c of Str x => emit emptyFC "\{els}if (! strcmp(\{cStringQuoted x}, ((Idris2_String *)\{sc'})->str)) {" Db x => emit emptyFC "\{els}if (((Idris2_Double *)\{sc'})->d == \{show x}) {" - x => throw $ InternalError "[refc] AConstCase : unsupported type. \{show fc} \{show x}" + x => throw $ InternalError "[refc] Administrative_Normal_Form_Constant_Case : unsupported type. \{show fc} \{show x}" concaseBody env switchReturnVar "" [] body tailPosition pure "} else ") "" alts pure () @@ -636,8 +636,8 @@ mutual emit emptyFC "}" pure switchReturnVar - cStatementsFromANF (APrimVal fc (I x)) tailPosition = cStatementsFromANF (APrimVal fc (I64 $ cast x)) tailPosition - cStatementsFromANF (APrimVal fc c) _ = do + cStatementsFromANF (Administrative_Normal_Form_Primitive_Value fc (I x)) tailPosition = cStatementsFromANF (Administrative_Normal_Form_Primitive_Value fc (I64 $ cast x)) tailPosition + cStatementsFromANF (Administrative_Normal_Form_Primitive_Value fc c) _ = do constdefs <- get ConstDef case lookup c constdefs of Just cdef => pure "((Idris2_Value*)&\{constantName cdef})" -- the constant already booked. @@ -674,8 +674,8 @@ mutual PrT t => pure $ cPrimType t WorldVal => pure "(NULL /* World */)" - cStatementsFromANF (AErased fc) _ = pure "NULL" - cStatementsFromANF (ACrash fc x) _ = pure "(NULL /* CRASH */)" + cStatementsFromANF (Administrative_Normal_Form_Erased_Value fc) _ = pure "NULL" + cStatementsFromANF (Administrative_Normal_Form_Crash fc x) _ = pure "(NULL /* CRASH */)" addCommaToList : List String -> List String addCommaToList [] = [] @@ -809,9 +809,9 @@ createCFunctions : {auto c : Ref Ctxt Defs} -> {auto h : Ref HeaderFiles (SortedSet String)} -> {default [] additionalFFILangs : List String} -> Name - -> ANFDef + -> Administrative_Normal_Form_Definition -> Core () -createCFunctions n (MkAFun args anf) = do +createCFunctions n (Make_Administrative_Normal_Form_Function args anf) = do let nargs = length args let fn = "Idris2_Value *\{cName !(getFullName n)}" ++ (if nargs == 0 then "(void)" @@ -819,7 +819,7 @@ createCFunctions n (MkAFun args anf) = do else ("\n(\n" ++ (showSep "\n" $ addCommaToList (map (\i => " Idris2_Value * var_" ++ (show i)) args))) ++ "\n)") update FunctionDefinitions $ \otherDefs => (fn ++ ";\n") :: otherDefs - let argsVars = fromList $ ALocal <$> args + let argsVars = fromList $ Administrative_Normal_Form_Local_Variable <$> args let bodyFreeVars = freeVariables anf let shouldDrop = difference argsVars bodyFreeVars let argsNrs = getArgsNrList args Z @@ -840,17 +840,17 @@ createCFunctions n (MkAFun args anf) = do pure () -createCFunctions n (MkACon Nothing _ _) = do +createCFunctions n (Make_Administrative_Normal_Form_Constructor Nothing _ _) = do let n' = cName n update FunctionDefinitions $ \otherDefs => "char const idris2_constr_\{n'}[];" :: otherDefs emit EmptyFC "char const idris2_constr_\{n'}[] = \{cStringQuoted $ show n};" pure () -createCFunctions n (MkACon tag arity nt) = do +createCFunctions n (Make_Administrative_Normal_Form_Constructor tag arity nt) = do emit EmptyFC $ ( "// \{show n} Constructor tag " ++ show tag ++ " arity " ++ show arity) -- Nothing to compile here -createCFunctions n (MkAForeign ccs fargs ret) = do +createCFunctions n (Make_Administrative_Normal_Form_Foreign_Function ccs fargs ret) = do case parseCC (additionalFFILangs ++ ["RefC", "C"]) ccs of Just (lang, fctForeignName :: extLibOpts) => do let cLang = if lang == "RefC" @@ -902,7 +902,7 @@ createCFunctions n (MkAForeign ccs fargs ret) = do _ => throw $ InternalError "[refc] FFI not found for \{cName n}" -- not really total but this way this internal error does not contaminate everything else -createCFunctions n (MkAError exp) = throw $ InternalError "[refc] Error with expression: \{show exp}" +createCFunctions n (Make_Administrative_Normal_Form_Error exp) = throw $ InternalError "[refc] Error with expression: \{show exp}" -- not really total but this way this internal error does not contaminate everything else @@ -968,7 +968,7 @@ footer = do export generateCSourceFile : {auto c : Ref Ctxt Defs} -> {default [] additionalFFILangs : List String} - -> List (Name, ANFDef) + -> List (Name, Administrative_Normal_Form_Definition) -> (outn : String) -> Core () generateCSourceFile defs outn = @@ -996,13 +996,13 @@ compileExpr : UsePhase -> ClosedTerm -> (outfile : String) -> Core (Maybe String) -compileExpr ANF c s _ outputDir tm outfile = +compileExpr Administrative_Normal_Form c s _ outputDir tm outfile = do let outn = outputDir outfile ++ ".c" let outobj = outputDir outfile ++ ".o" let outexec = outputDir outfile coreLift_ $ mkdirAll outputDir - cdata <- getCompileData False ANF tm + cdata <- getCompileData False Administrative_Normal_Form tm let defs = anf cdata generateCSourceFile defs outn @@ -1019,10 +1019,10 @@ executeExpr : Ref Ctxt Defs -> Ref Syn SyntaxInfo -> (execDir : String) -> ClosedTerm -> Core () executeExpr c s tmpDir tm = do do let outfile = "_tmp_refc" - Just _ <- compileExpr ANF c s tmpDir tmpDir tm outfile + Just _ <- compileExpr Administrative_Normal_Form c s tmpDir tmpDir tm outfile | Nothing => do coreLift_ $ putStrLn "Error: failed to compile" coreLift_ $ system (tmpDir outfile) export codegenRefC : Codegen -codegenRefC = MkCG (compileExpr ANF) executeExpr Nothing Nothing +codegenRefC = MkCG (compileExpr Administrative_Normal_Form) executeExpr Nothing Nothing diff --git a/Compiler/VMCode.idr b/Compiler/VMCode.idr index 0f9f7cdef7..9765edf788 100644 --- a/Compiler/VMCode.idr +++ b/Compiler/VMCode.idr @@ -108,9 +108,9 @@ Show VMDef where show args ++ " " ++ show ret show (MkVMError err) = "Error: " ++ show err -toReg : AVar -> Reg -toReg (ALocal i) = Loc i -toReg ANull = Discard +toReg : Administrative_Normal_Form_Variable -> Reg +toReg (Administrative_Normal_Form_Local_Variable i) = Loc i +toReg Administrative_Normal_Form_Erased_Variable = Discard projectArgs : Int -> Int -> (used : IntMap ()) -> (args : List Int) -> List VMInst projectArgs scr i used [] = [] @@ -146,49 +146,49 @@ collectUsed (PROJECT _ val _) = collectReg val collectUsed (NULL _) = empty collectUsed (ERROR _) = empty -toVM : (tailpos : Bool) -> (target : Reg) -> ANF -> List VMInst +toVM : (tailpos : Bool) -> (target : Reg) -> Administrative_Normal_Form -> List VMInst toVM t Discard _ = [] -toVM t res (AV fc (ALocal i)) +toVM t res (Administrative_Normal_Form_Variable_Expression fc (Administrative_Normal_Form_Local_Variable i)) = [ASSIGN res (Loc i)] -toVM t res (AAppName fc _ n args) +toVM t res (Administrative_Normal_Form_Named_Function_Application fc _ n args) = [CALL res t n (map toReg args)] -toVM t res (AUnderApp fc n m args) +toVM t res (Administrative_Normal_Form_Partial_Application fc n m args) = [MKCLOSURE res n m (map toReg args)] -toVM t res (AApp fc _ f a) +toVM t res (Administrative_Normal_Form_Closure_Application fc _ f a) = [APPLY res (toReg f) (toReg a)] -toVM t res (ALet fc var val body) +toVM t res (Administrative_Normal_Form_Binding fc var val body) = toVM False (Loc var) val ++ toVM t res body -toVM t res (ACon fc n ci (Just tag) args) +toVM t res (Administrative_Normal_Form_Constructor_Value fc n ci (Just tag) args) = [MKCON res (Left tag) (map toReg args)] -toVM t res (ACon fc n ci Nothing args) +toVM t res (Administrative_Normal_Form_Constructor_Value fc n ci Nothing args) = [MKCON res (Right n) (map toReg args)] -toVM t res (AOp fc _ op args) +toVM t res (Administrative_Normal_Form_Primitive_Operation fc _ op args) = [OP res op (map toReg args)] -toVM t res (AExtPrim fc _ p args) +toVM t res (Administrative_Normal_Form_External_Primitive fc _ p args) = [EXTPRIM res p (map toReg args)] -toVM t res (AConCase fc (ALocal scr) [MkAConAlt n ci mt args code] Nothing) -- exactly one alternative, so skip matching +toVM t res (Administrative_Normal_Form_Constructor_Case fc (Administrative_Normal_Form_Local_Variable scr) [Make_Administrative_Normal_Form_Constructor_Alternative n ci mt args code] Nothing) -- exactly one alternative, so skip matching = let body = toVM t res code used = foldMap collectUsed body in projectArgs scr 0 used args ++ body -toVM t res (AConCase fc (ALocal scr) alts def) +toVM t res (Administrative_Normal_Form_Constructor_Case fc (Administrative_Normal_Form_Local_Variable scr) alts def) = [CASE (Loc scr) (map toVMConAlt alts) (map (toVM t res) def)] where - toVMConAlt : AConAlt -> (Either Int Name, List VMInst) - toVMConAlt (MkAConAlt n ci tag args code) + toVMConAlt : Administrative_Normal_Form_Constructor_Alternative -> (Either Int Name, List VMInst) + toVMConAlt (Make_Administrative_Normal_Form_Constructor_Alternative n ci tag args code) = let body = toVM t res code used = foldMap collectUsed body in (maybe (Right n) Left tag, projectArgs scr 0 used args ++ body) -toVM t res (AConstCase fc (ALocal scr) alts def) +toVM t res (Administrative_Normal_Form_Constant_Case fc (Administrative_Normal_Form_Local_Variable scr) alts def) = [CONSTCASE (Loc scr) (map toVMConstAlt alts) (map (toVM t res) def)] where - toVMConstAlt : AConstAlt -> (Constant, List VMInst) - toVMConstAlt (MkAConstAlt c code) + toVMConstAlt : Administrative_Normal_Form_Constant_Alternative -> (Constant, List VMInst) + toVMConstAlt (Make_Administrative_Normal_Form_Constant_Alternative c code) = (c, toVM t res code) -toVM t res (APrimVal fc c) +toVM t res (Administrative_Normal_Form_Primitive_Value fc c) = [MKCONSTANT res c] -toVM t res (AErased fc) +toVM t res (Administrative_Normal_Form_Erased_Value fc) = [NULL res] -toVM t res (ACrash fc err) +toVM t res (Administrative_Normal_Form_Crash fc err) = [ERROR err] toVM t res _ = [NULL res] @@ -228,15 +228,15 @@ declareVars got code else DECLARE (Loc i) :: declareAll (i :: got) is export -toVMDef : ANFDef -> Maybe VMDef -toVMDef (MkAFun args body) +toVMDef : Administrative_Normal_Form_Definition -> Maybe VMDef +toVMDef (Make_Administrative_Normal_Form_Function args body) = Just $ MkVMFun args (declareVars args (toVM True RVal body)) -toVMDef (MkAForeign ccs cargs ret) +toVMDef (Make_Administrative_Normal_Form_Foreign_Function ccs cargs ret) = Just $ MkVMForeign ccs cargs ret -toVMDef (MkAError body) +toVMDef (Make_Administrative_Normal_Form_Error body) = Just $ MkVMError (declareVars [] (toVM True RVal body)) toVMDef _ = Nothing export -allDefs : List (Name, ANFDef) -> List (Name, VMDef) +allDefs : List (Name, Administrative_Normal_Form_Definition) -> List (Name, VMDef) allDefs = mapMaybe (\ (n, d) => do d' <- toVMDef d; pure (n, d')) diff --git a/Core/Options.idr b/Core/Options.idr index c11964d8ad..366c33f21b 100644 --- a/Core/Options.idr +++ b/Core/Options.idr @@ -178,7 +178,7 @@ record Session where debugElabCheck : Bool -- do conversion check to verify results of elaborator dumpcases : Maybe String -- file to output compiled case trees dumplifted : Maybe String -- file to output lambda lifted definitions - dumpanf : Maybe String -- file to output ANF definitions + dumpanf : Maybe String -- file to output Administrative_Normal_Form definitions dumpvmcode : Maybe String -- file to output VM code definitions profile : Bool -- generate profiling information, if supported logErrorCount : Nat -- when parsing alternatives fails, how many errors diff --git a/Idris/CommandLine.idr b/Idris/CommandLine.idr index 53dbbb2a4b..3248bc3dee 100644 --- a/Idris/CommandLine.idr +++ b/Idris/CommandLine.idr @@ -138,7 +138,7 @@ data CLOpt DumpCases String | ||| Dump lambda lifted defs before compiling DumpLifted String | - ||| Dump ANF defs before compiling + ||| Dump Administrative_Normal_Form defs before compiling DumpANF String | ||| Dump VM code defs before compiling DumpVMCode String | @@ -370,7 +370,7 @@ options = [MkOpt ["--check", "-c"] [] [CheckOnly] MkOpt ["--dumplifted"] [Required "output file"] (\f => [DumpLifted f]) Nothing, -- dump lambda lifted trees to the given file MkOpt ["--dumpanf"] [Required "output file"] (\f => [DumpANF f]) - Nothing, -- dump ANF to the given file + Nothing, -- dump Administrative_Normal_Form to the given file MkOpt ["--dumpvmcode"] [Required "output file"] (\f => [DumpVMCode f]) Nothing, -- dump VM Code to the given file MkOpt ["--debug-elab-check"] [] [DebugElabCheck] diff --git a/Idris/Desugar.idr b/Idris/Desugar.idr index de32ef7b00..cb373f0617 100644 --- a/Idris/Desugar.idr +++ b/Idris/Desugar.idr @@ -252,33 +252,33 @@ addNS _ n = n bindFun : FC -> Maybe Namespace -> RawImp -> RawImp -> RawImp bindFun fc ns ma f = let fc = virtualiseFC fc in - Elaboratable_Apply fc (Elaboratable_Apply fc (Elaboratable_Name fc (addNS ns $ UN $ Basic ">>=")) ma) f + Elaborable_Apply fc (Elaborable_Apply fc (Elaborable_Name fc (addNS ns $ UN $ Basic ">>=")) ma) f seqFun : FC -> Maybe Namespace -> RawImp -> RawImp -> RawImp seqFun fc ns ma mb = let fc = virtualiseFC fc in - Elaboratable_Apply fc (Elaboratable_Apply fc (Elaboratable_Name fc (addNS ns (UN $ Basic ">>"))) ma) mb + Elaborable_Apply fc (Elaborable_Apply fc (Elaborable_Name fc (addNS ns (UN $ Basic ">>"))) ma) mb bindBangs : List (Name, FC, RawImp) -> Maybe Namespace -> RawImp -> RawImp bindBangs [] ns tm = tm bindBangs ((n, fc, btm) :: bs) ns tm = bindBangs bs ns $ bindFun fc ns btm - $ Elaboratable_Lambda EmptyFC top Explicit (Just n) (Implicit fc False) tm + $ Elaborable_Lambda EmptyFC top Explicit (Just n) (Implicit fc False) tm idiomise : FC -> Maybe Namespace -> Maybe Namespace -> RawImp -> RawImp -idiomise fc dons mns (Elaboratable_Alternative afc u alts) - = Elaboratable_Alternative afc (mapAltType (idiomise afc dons mns) u) (idiomise afc dons mns <$> alts) -idiomise fc dons mns (Elaboratable_Apply afc f a) +idiomise fc dons mns (Elaborable_Alternative afc u alts) + = Elaborable_Alternative afc (mapAltType (idiomise afc dons mns) u) (idiomise afc dons mns <$> alts) +idiomise fc dons mns (Elaborable_Apply afc f a) = let fc = virtualiseFC fc app = UN $ Basic "<*>" nm = maybe app (`NS` app) (mns <|> dons) - in Elaboratable_Apply fc (Elaboratable_Apply fc (Elaboratable_Name fc nm) (idiomise afc dons mns f)) a + in Elaborable_Apply fc (Elaborable_Apply fc (Elaborable_Name fc nm) (idiomise afc dons mns f)) a idiomise fc dons mns fn = let fc = virtualiseFC fc pur = UN $ Basic "pure" nm = maybe pur (`NS` pur) (mns <|> dons) - in Elaboratable_Apply fc (Elaboratable_Name fc nm) fn + in Elaborable_Apply fc (Elaborable_Name fc nm) fn data Bang : Type where @@ -294,8 +294,8 @@ mutual let ns = mbNamespace !(get Bang) let pur = UN $ Basic "pure" case x == pur of -- implicitly add namespace to unqualified occurrences of `pure` in a qualified do-block - False => pure $ Elaboratable_Name fc x - True => pure $ Elaboratable_Name fc (maybe pur (`NS` pur) ns) + False => pure $ Elaborable_Name fc x + True => pure $ Elaborable_Name fc (maybe pur (`NS` pur) ns) -- Desugaring forall n1, n2, n3 . s into -- {0 n1 : ?} -> {0 n2 : ?} -> {0 n3 : ?} -> s @@ -306,7 +306,7 @@ mutual (names : List (WithFC Name)) -> Core RawImp desugarForallNames ctx [] = desugarB side ctx scope desugarForallNames ctx (x :: xs) - = Elaboratable_Dependent_Function_Type x.fc erased Implicit (Just x.val) + = Elaborable_Dependent_Function_Type x.fc erased Implicit (Just x.val) <$> desugarB side ps (PImplicit x.fc) <*> desugarForallNames (x.val :: ctx) xs @@ -322,7 +322,7 @@ mutual = desugarB side ctx scope desugarMultiBinder ctx (name :: xs) = let extendedCtx = name.val :: ps - in Elaboratable_Dependent_Function_Type binder.fc rig + in Elaborable_Dependent_Function_Type binder.fc rig <$> mapDesugarPiInfo extendedCtx info <*> (pure (Just name.val)) <*> desugarB side ps type @@ -330,40 +330,40 @@ mutual desugarB side ps (PPi fc rig p mn argTy retTy) = let ps' = maybe ps (:: ps) mn in - pure $ Elaboratable_Dependent_Function_Type fc rig !(traverse (desugar side ps') p) + pure $ Elaborable_Dependent_Function_Type fc rig !(traverse (desugar side ps') p) mn !(desugarB side ps argTy) !(desugarB side ps' retTy) desugarB side ps (PLam fc rig p pat@(PRef prefFC n@(UN nm)) argTy scope) = if isPatternVariable nm then do whenJust (isConcreteFC prefFC) $ \nfc => addSemanticDecorations [(nfc, Bound, Just n)] - pure $ Elaboratable_Lambda fc rig !(traverse (desugar AnyExpr ps) p) + pure $ Elaborable_Lambda fc rig !(traverse (desugar AnyExpr ps) p) (Just n) !(desugarB AnyExpr ps argTy) !(desugar AnyExpr (n :: ps) scope) - else pure $ Elaboratable_Lambda EmptyFC rig !(traverse (desugar AnyExpr ps) p) + else pure $ Elaborable_Lambda EmptyFC rig !(traverse (desugar AnyExpr ps) p) (Just (MN "lamc" 0)) !(desugarB AnyExpr ps argTy) $ - Elaboratable_Case fc [] (Elaboratable_Name EmptyFC (MN "lamc" 0)) (Implicit fc False) + Elaborable_Case fc [] (Elaborable_Name EmptyFC (MN "lamc" 0)) (Implicit fc False) [snd !(desugarClause ps True (MkPatClause fc pat scope []))] desugarB side ps (PLam fc rig p (PRef _ n@(MN {})) argTy scope) - = pure $ Elaboratable_Lambda fc rig !(traverse (desugar AnyExpr ps) p) + = pure $ Elaborable_Lambda fc rig !(traverse (desugar AnyExpr ps) p) (Just n) !(desugarB AnyExpr ps argTy) !(desugar AnyExpr (n :: ps) scope) desugarB side ps (PLam fc rig p (PImplicit _) argTy scope) - = pure $ Elaboratable_Lambda fc rig !(traverse (desugar AnyExpr ps) p) + = pure $ Elaborable_Lambda fc rig !(traverse (desugar AnyExpr ps) p) Nothing !(desugarB AnyExpr ps argTy) !(desugar AnyExpr ps scope) desugarB side ps (PLam fc rig p pat argTy scope) - = pure $ Elaboratable_Lambda EmptyFC rig !(traverse (desugar AnyExpr ps) p) + = pure $ Elaborable_Lambda EmptyFC rig !(traverse (desugar AnyExpr ps) p) (Just (MN "lamc" 0)) !(desugarB AnyExpr ps argTy) $ - Elaboratable_Case fc [] (Elaboratable_Name EmptyFC (MN "lamc" 0)) (Implicit fc False) + Elaborable_Case fc [] (Elaborable_Name EmptyFC (MN "lamc" 0)) (Implicit fc False) [snd !(desugarClause ps True (MkPatClause fc pat scope []))] desugarB side ps (PLet fc rig (PRef prefFC n) nTy nVal scope []) = do whenJust (isConcreteFC prefFC) $ \nfc => addSemanticDecorations [(nfc, Bound, Just n)] - pure $ Elaboratable_Binding fc prefFC rig n !(desugarB side ps nTy) !(desugarB side ps nVal) + pure $ Elaborable_Binding fc prefFC rig n !(desugarB side ps nTy) !(desugarB side ps nVal) !(desugar side (n :: ps) scope) desugarB side ps (PLet fc rig pat nTy nVal scope alts) - = pure $ Elaboratable_Case fc [] !(desugarB side ps nVal) !(desugarB side ps nTy) + = pure $ Elaborable_Case fc [] !(desugarB side ps nVal) !(desugarB side ps nTy) !(traverse (map snd . desugarClause ps True) (MkPatClause fc pat scope [] :: alts)) desugarB side ps (PCase fc opts scr cls) @@ -371,13 +371,13 @@ mutual scr <- desugarB side ps scr let scrty = Implicit (virtualiseFC fc) False cls <- traverse (map snd . desugarClause ps True) cls - pure $ Elaboratable_Case fc opts scr scrty cls + pure $ Elaborable_Case fc opts scr scrty cls desugarB side ps (PLocal fc xs scope) = let ps' = definedIn (map val xs) ++ ps in - pure $ Elaboratable_Local_Definitions fc (concat !(traverse (desugarDecl ps') xs)) + pure $ Elaborable_Local_Definitions fc (concat !(traverse (desugarDecl ps') xs)) !(desugar side ps' scope) desugarB side ps (PApp pfc (PUpdate fc fs) rec) - = pure $ Elaboratable_Record_Update pfc !(traverse (desugarUpdate side ps) fs) + = pure $ Elaborable_Record_Update pfc !(traverse (desugarUpdate side ps) fs) !(desugarB side ps rec) desugarB side ps (PUpdate fc fs) = desugarB side ps @@ -385,25 +385,25 @@ mutual PLam vfc top Explicit (PRef vfc (MN "rec" 0)) (PImplicit vfc) $ PApp vfc (PUpdate fc fs) (PRef vfc (MN "rec" 0)) desugarB side ps (PApp fc x y) - = pure $ Elaboratable_Apply fc !(desugarB side ps x) !(desugarB side ps y) + = pure $ Elaborable_Apply fc !(desugarB side ps x) !(desugarB side ps y) desugarB side ps (PAutoApp fc x y) - = pure $ Elaboratable_Automatic_Apply fc !(desugarB side ps x) !(desugarB side ps y) + = pure $ Elaborable_Automatic_Apply fc !(desugarB side ps x) !(desugarB side ps y) desugarB side ps (PWithApp fc x y) - = pure $ Elaboratable_With_Apply fc !(desugarB side ps x) !(desugarB side ps y) + = pure $ Elaborable_With_Apply fc !(desugarB side ps x) !(desugarB side ps y) desugarB side ps (PNamedApp fc x argn y) - = pure $ Elaboratable_Named_Apply fc !(desugarB side ps x) argn !(desugarB side ps y) + = pure $ Elaborable_Named_Apply fc !(desugarB side ps x) argn !(desugarB side ps y) desugarB side ps (PDelayed fc r ty) - = pure $ Elaboratable_Delayed_Type fc r !(desugarB side ps ty) + = pure $ Elaborable_Delayed_Type fc r !(desugarB side ps ty) desugarB side ps (PDelay fc tm) - = pure $ Elaboratable_Delay fc !(desugarB side ps tm) + = pure $ Elaborable_Delay fc !(desugarB side ps tm) desugarB side ps (PForce fc tm) - = pure $ Elaboratable_Force fc !(desugarB side ps tm) + = pure $ Elaborable_Force fc !(desugarB side ps tm) desugarB side ps (PEq fc l r) = do l' <- desugarB side ps l r' <- desugarB side ps r - pure $ Elaboratable_Alternative fc FirstSuccess - [apply (Elaboratable_Name fc (UN $ Basic "===")) [l', r'], - apply (Elaboratable_Name fc (UN $ Basic "~=~")) [l', r']] + pure $ Elaborable_Alternative fc FirstSuccess + [apply (Elaborable_Name fc (UN $ Basic "===")) [l', r'], + apply (Elaborable_Name fc (UN $ Basic "~=~")) [l', r']] desugarB side ps (PBracketed fc e) = desugarB side ps e desugarB side ps (POp fc l op r) = do ts <- toTokList side (POp fc l op r) @@ -429,59 +429,59 @@ mutual = desugarB side ps (PLam fc top Explicit (PRef fc (MN "arg" 0)) (PImplicit fc) (POp fc (MkFCVal op.fc $ NoBinder arg) op (PRef fc (MN "arg" 0)))) - desugarB side ps (PSearch fc depth) = pure $ Elaboratable_Search fc depth + desugarB side ps (PSearch fc depth) = pure $ Elaborable_Search fc depth desugarB side ps (PPrimVal fc (BI x)) = case !fromIntegerName of Nothing => - pure $ Elaboratable_Alternative fc (UniqueDefault (Elaboratable_Primitive_Value fc (BI x))) - [Elaboratable_Primitive_Value fc (BI x), - Elaboratable_Primitive_Value fc (I (fromInteger x))] + pure $ Elaborable_Alternative fc (UniqueDefault (Elaborable_Primitive_Value fc (BI x))) + [Elaborable_Primitive_Value fc (BI x), + Elaborable_Primitive_Value fc (I (fromInteger x))] Just fi => let vfc = virtualiseFC fc in - pure $ Elaboratable_Apply vfc (Elaboratable_Name vfc fi) (Elaboratable_Primitive_Value fc (BI x)) + pure $ Elaborable_Apply vfc (Elaborable_Name vfc fi) (Elaborable_Primitive_Value fc (BI x)) desugarB side ps (PPrimVal fc (Ch x)) = case !fromCharName of Nothing => - pure $ Elaboratable_Primitive_Value fc (Ch x) + pure $ Elaborable_Primitive_Value fc (Ch x) Just f => let vfc = virtualiseFC fc in - pure $ Elaboratable_Apply vfc (Elaboratable_Name vfc f) (Elaboratable_Primitive_Value fc (Ch x)) + pure $ Elaborable_Apply vfc (Elaborable_Name vfc f) (Elaborable_Primitive_Value fc (Ch x)) desugarB side ps (PPrimVal fc (Db x)) = case !fromDoubleName of Nothing => - pure $ Elaboratable_Primitive_Value fc (Db x) + pure $ Elaborable_Primitive_Value fc (Db x) Just f => let vfc = virtualiseFC fc in - pure $ Elaboratable_Apply vfc (Elaboratable_Name vfc f) (Elaboratable_Primitive_Value fc (Db x)) - desugarB side ps (PPrimVal fc x) = pure $ Elaboratable_Primitive_Value fc x + pure $ Elaborable_Apply vfc (Elaborable_Name vfc f) (Elaborable_Primitive_Value fc (Db x)) + desugarB side ps (PPrimVal fc x) = pure $ Elaborable_Primitive_Value fc x desugarB side ps (PQuote fc tm) - = do let q = Elaboratable_Quote fc !(desugarB side ps tm) + = do let q = Elaborable_Quote fc !(desugarB side ps tm) case side of AnyExpr => pure $ maybeIApp fc !fromTTImpName q _ => pure q desugarB side ps (PQuoteName fc n) - = do let q = Elaboratable_Quote_Name fc n + = do let q = Elaborable_Quote_Name fc n case side of AnyExpr => pure $ maybeIApp fc !fromNameName q _ => pure q desugarB side ps (PQuoteDecl fc x) = do xs <- traverse (desugarDecl ps) x - let dls = Elaboratable_Quote_Declarations fc (concat xs) + let dls = Elaborable_Quote_Declarations fc (concat xs) case side of AnyExpr => pure $ maybeIApp fc !fromDeclsName dls _ => pure dls desugarB side ps (PUnquote fc tm) - = pure $ Elaboratable_Unquote fc !(desugarB side ps tm) + = pure $ Elaborable_Unquote fc !(desugarB side ps tm) desugarB side ps (PRunElab fc tm) - = pure $ Elaboratable_Run_Elaborator fc True !(desugarB side ps tm) + = pure $ Elaborable_Run_Elaborator fc True !(desugarB side ps tm) desugarB side ps (PHole fc br holename) = do when br $ update Syn { bracketholes $= ((UN (Basic holename)) ::) } - pure $ Elaboratable_Hole fc holename - desugarB side ps (PType fc) = pure $ Elaboratable_Type_Universe fc + pure $ Elaborable_Hole fc holename + desugarB side ps (PType fc) = pure $ Elaborable_Type_Universe fc desugarB side ps (PAs fc nameFC vname pattern) - = pure $ Elaboratable_As_Pattern fc nameFC UseRight vname !(desugarB side ps pattern) + = pure $ Elaborable_As_Pattern fc nameFC UseRight vname !(desugarB side ps pattern) desugarB side ps (PDotted fc x) - = pure $ Elaboratable_Must_Unify fc UserDotted !(desugarB side ps x) + = pure $ Elaborable_Must_Unify fc UserDotted !(desugarB side ps x) desugarB side ps (PImplicit fc) = pure $ Implicit fc True desugarB side ps (PInfer fc) = do when (side == LHS) $ @@ -495,10 +495,10 @@ mutual -- are always concatenated with other strings and therefore can never use -- another `fromString` implementation that differs from `id`. desugarB side ps (PString fc hashtag []) - = pure $ maybeIApp fc !fromStringName (Elaboratable_Primitive_Value fc (Str "")) + = pure $ maybeIApp fc !fromStringName (Elaborable_Primitive_Value fc (Str "")) desugarB side ps (PString fc hashtag [StrLiteral fc' str]) = case unescape hashtag str of - Just str => pure $ maybeIApp fc !fromStringName (Elaboratable_Primitive_Value fc' (Str str)) + Just str => pure $ maybeIApp fc !fromStringName (Elaborable_Primitive_Value fc' (Str str)) Nothing => throw (GenericMsg fc "Invalid escape sequence: \{show str}") desugarB side ps (PString fc hashtag strs) = expandString side ps fc hashtag strs @@ -512,7 +512,7 @@ mutual put Bang ({ nextName $= (+1), bangNames $= ((bn, fc, itm) ::) } bs) - pure (Elaboratable_Name (virtualiseFC fc) bn) + pure (Elaborable_Name (virtualiseFC fc) bn) desugarB side ps (PIdiom fc ns term) = do itm <- desugarB side ps term logRaw "desugar.idiom" 10 "Desugaring idiom for" itm @@ -526,40 +526,40 @@ mutual desugarB side ps (PPair fc l r) = do l' <- desugarB side ps l r' <- desugarB side ps r - let pval = apply (Elaboratable_Name fc mkpairname) [l', r'] - pure $ Elaboratable_Alternative fc (UniqueDefault pval) - [apply (Elaboratable_Name fc pairname) [l', r'], pval] + let pval = apply (Elaborable_Name fc mkpairname) [l', r'] + pure $ Elaborable_Alternative fc (UniqueDefault pval) + [apply (Elaborable_Name fc pairname) [l', r'], pval] desugarB side ps (PDPair fc opFC (PRef nameFC n@(UN _)) (PImplicit _) r) = do r' <- desugarB side ps r - let pval = apply (Elaboratable_Name opFC mkdpairname) [Elaboratable_Name nameFC n, r'] + let pval = apply (Elaborable_Name opFC mkdpairname) [Elaborable_Name nameFC n, r'] let vfc = virtualiseFC nameFC whenJust (isConcreteFC nameFC) $ \nfc => addSemanticDefault (nfc, Bound, Just n) - pure $ Elaboratable_Alternative fc (UniqueDefault pval) - [apply (Elaboratable_Name opFC dpairname) + pure $ Elaborable_Alternative fc (UniqueDefault pval) + [apply (Elaborable_Name opFC dpairname) [Implicit vfc False, - Elaboratable_Lambda nameFC top Explicit (Just n) (Implicit vfc False) r'], + Elaborable_Lambda nameFC top Explicit (Just n) (Implicit vfc False) r'], pval] desugarB side ps (PDPair fc opFC (PRef namefc n@(UN _)) ty r) = do ty' <- desugarB side ps ty r' <- desugarB side ps r - pure $ apply (Elaboratable_Name opFC dpairname) - [ty', Elaboratable_Lambda namefc top Explicit (Just n) ty' r'] + pure $ apply (Elaborable_Name opFC dpairname) + [ty', Elaborable_Lambda namefc top Explicit (Just n) ty' r'] desugarB side ps (PDPair fc opFC l (PImplicit _) r) = do l' <- desugarB side ps l r' <- desugarB side ps r - pure $ apply (Elaboratable_Name opFC mkdpairname) [l', r'] + pure $ apply (Elaborable_Name opFC mkdpairname) [l', r'] desugarB side ps (PDPair fc opFC l ty r) = throw (GenericMsg fc "Invalid dependent pair type") desugarB side ps (PUnit fc) - = pure $ Elaboratable_Alternative fc (UniqueDefault (Elaboratable_Name fc (UN $ Basic "MkUnit"))) - [Elaboratable_Name fc (UN $ Basic "Unit"), - Elaboratable_Name fc (UN $ Basic "MkUnit")] + = pure $ Elaborable_Alternative fc (UniqueDefault (Elaborable_Name fc (UN $ Basic "MkUnit"))) + [Elaborable_Name fc (UN $ Basic "Unit"), + Elaborable_Name fc (UN $ Basic "MkUnit")] desugarB side ps (PIfThenElse fc x t e) = let fc = virtualiseFC fc in - pure $ Elaboratable_Case fc [] !(desugarB side ps x) (Elaboratable_Name fc (UN $ Basic "Bool")) - [PatClause fc (Elaboratable_Name fc (UN $ Basic "True")) !(desugar side ps t), - PatClause fc (Elaboratable_Name fc (UN $ Basic "False")) !(desugar side ps e)] + pure $ Elaborable_Case fc [] !(desugarB side ps x) (Elaborable_Name fc (UN $ Basic "Bool")) + [PatClause fc (Elaborable_Name fc (UN $ Basic "True")) !(desugar side ps t), + PatClause fc (Elaborable_Name fc (UN $ Basic "False")) !(desugar side ps e)] desugarB side ps (PComprehension fc ret conds) = do let ns = mbNamespace !(get Bang) desugarB side ps (PDoBlock fc ns (map (guard ns) conds ++ [toPure ns ret])) @@ -572,7 +572,7 @@ mutual toPure : Maybe Namespace -> PTerm -> PDo toPure ns tm = DoExp fc (PApp fc (PRef fc (mbApplyNS ns $ UN $ Basic "pure")) tm) desugarB side ps (PRewrite fc rule tm) - = pure $ Elaboratable_Rewrite fc !(desugarB side ps rule) !(desugarB side ps tm) + = pure $ Elaborable_Rewrite fc !(desugarB side ps rule) !(desugarB side ps tm) desugarB side ps (PRange fc start next end) = let fc = virtualiseFC fc in desugarB side ps $ case next of @@ -584,7 +584,7 @@ mutual Nothing => papply fc (PRef fc (UN $ Basic "rangeFrom")) [start] Just n => papply fc (PRef fc (UN $ Basic "rangeFromThen")) [start, n] desugarB side ps (PUnifyLog fc lvl tm) - = pure $ Elaboratable_Unification_Log fc lvl !(desugarB side ps tm) + = pure $ Elaborable_Unification_Log fc lvl !(desugarB side ps tm) desugarB side ps (PPostfixApp fc rec projs) = desugarB side ps $ foldl (\x, (fc, proj) => PApp fc (PRef fc proj) x) rec projs @@ -595,7 +595,7 @@ mutual PLam fc top Explicit var (PImplicit vfc) $ foldl (\r, (fc, proj) => PApp fc (PRef fc proj) r) var projs desugarB side ps (PWithUnambigNames fc ns rhs) - = Elaboratable_With_Unambiguous_Names fc ns <$> desugarB side ps rhs + = Elaborable_With_Unambiguous_Names fc ns <$> desugarB side ps rhs desugarUpdate : {auto s : Ref Syn SyntaxInfo} -> {auto b : Ref Bang BangData} -> @@ -603,11 +603,11 @@ mutual {auto u : Ref UST UState} -> {auto m : Ref MD Metadata} -> {auto o : Ref ROpts REPLOpts} -> - Side -> List Name -> PFieldUpdate -> Core Elaboratable_Field_Update + Side -> List Name -> PFieldUpdate -> Core Elaborable_Field_Update desugarUpdate side ps (PSetField p v) - = pure (Elaboratable_Set_Field p !(desugarB side ps v)) + = pure (Elaborable_Set_Field p !(desugarB side ps v)) desugarUpdate side ps (PSetFieldApp p v) - = pure (Elaboratable_Apply_To_Field p !(desugarB side ps v)) + = pure (Elaborable_Apply_To_Field p !(desugarB side ps v)) expandList : {auto s : Ref Syn SyntaxInfo} -> {auto b : Ref Bang BangData} -> @@ -617,9 +617,9 @@ mutual {auto o : Ref ROpts REPLOpts} -> Side -> List Name -> (nilFC : FC) -> List (FC, PTerm) -> Core RawImp - expandList side ps nilFC [] = pure (Elaboratable_Name nilFC (UN $ Basic "Nil")) + expandList side ps nilFC [] = pure (Elaborable_Name nilFC (UN $ Basic "Nil")) expandList side ps nilFC ((consFC, x) :: xs) - = pure $ apply (Elaboratable_Name consFC (UN $ Basic "::")) + = pure $ apply (Elaborable_Name consFC (UN $ Basic "::")) [!(desugarB side ps x), !(expandList side ps nilFC xs)] expandSnocList @@ -631,9 +631,9 @@ mutual {auto o : Ref ROpts REPLOpts} -> Side -> List Name -> (nilFC : FC) -> SnocList (FC, PTerm) -> Core RawImp - expandSnocList side ps nilFC [<] = pure (Elaboratable_Name nilFC (UN $ Basic "Lin")) + expandSnocList side ps nilFC [<] = pure (Elaborable_Name nilFC (UN $ Basic "Lin")) expandSnocList side ps nilFC (xs :< (consFC, x)) - = pure $ apply (Elaboratable_Name consFC (UN $ Basic ":<")) + = pure $ apply (Elaborable_Name consFC (UN $ Basic ":<")) [!(expandSnocList side ps nilFC xs) , !(desugarB side ps x)] maybeIApp : FC -> Maybe Name -> RawImp -> RawImp @@ -642,7 +642,7 @@ mutual Nothing => tm Just f => let fc = virtualiseFC fc in - Elaboratable_Apply fc (Elaboratable_Name fc f) tm + Elaborable_Apply fc (Elaborable_Name fc f) tm expandString : {auto s : Ref Syn SyntaxInfo} -> {auto b : Ref Bang BangData} -> @@ -654,20 +654,20 @@ mutual expandString side ps fc hashtag xs = do xs <- traverse toRawImp (filter notEmpty $ mergeStrLit xs) pure $ case xs of - [] => Elaboratable_Primitive_Value fc (Str "") + [] => Elaborable_Primitive_Value fc (Str "") (_ :: _) => let vfc = virtualiseFC fc in - Elaboratable_Apply vfc - (Elaboratable_Named_Apply vfc - (Elaboratable_Name vfc (NS preludeNS $ UN $ Basic "concat")) + Elaborable_Apply vfc + (Elaborable_Named_Apply vfc + (Elaborable_Name vfc (NS preludeNS $ UN $ Basic "concat")) (UN $ Basic "t") - (Elaboratable_Name vfc (NS preludeNS $ UN $ Basic "List"))) + (Elaborable_Name vfc (NS preludeNS $ UN $ Basic "List"))) (strInterpolate xs) where toRawImp : PStr -> Core RawImp toRawImp (StrLiteral fc str) = case unescape hashtag str of - Just str => pure $ Elaboratable_Primitive_Value fc (Str str) + Just str => pure $ Elaborable_Primitive_Value fc (Str str) Nothing => throw (GenericMsg fc "Invalid escape sequence: \{show str}") toRawImp (StrInterp fc tm) = desugarB side ps tm @@ -688,11 +688,11 @@ mutual strInterpolate : List RawImp -> RawImp strInterpolate [] - = Elaboratable_Name EmptyFC nilName + = Elaborable_Name EmptyFC nilName strInterpolate (x :: xs) = let xFC = virtualiseFC (getFC x) in - apply (Elaboratable_Name xFC consName) - [ Elaboratable_Apply xFC (Elaboratable_Name EmptyFC interpolateName) + apply (Elaborable_Name xFC consName) + [ Elaborable_Apply xFC (Elaborable_Name EmptyFC interpolateName) x , strInterpolate xs ] @@ -764,7 +764,7 @@ mutual (\ty => desugarDo side ps ns ty) ty rest' <- expandDo side ps topfc ns rest pure $ bindFun fc ns tm' - $ Elaboratable_Lambda nameFC rig Explicit (Just n) ty' rest' + $ Elaborable_Lambda nameFC rig Explicit (Just n) ty' rest' expandDo side ps topfc ns (DoBindPat fc pat ty exp alts :: rest) = do pat' <- desugarDo LHS ps ns pat (newps, bpat) <- bindNames False pat' @@ -778,9 +778,9 @@ mutual (\ty => desugarDo side ps ns ty) ty rest' <- expandDo side ps' topfc ns rest pure $ bindFun fc ns exp' - $ Elaboratable_Lambda EmptyFC top Explicit (Just (MN "_" 0)) + $ Elaborable_Lambda EmptyFC top Explicit (Just (MN "_" 0)) ty' - (Elaboratable_Case fc [] (Elaboratable_Name patFC (MN "_" 0)) + (Elaborable_Case fc [] (Elaborable_Name patFC (MN "_" 0)) (Implicit fc False) (PatClause fcOriginal bpat rest' :: alts')) @@ -791,7 +791,7 @@ mutual rest' <- expandDo side ps topfc ns rest whenJust (isConcreteFC lhsFC) $ \nfc => addSemanticDecorations [(nfc, Bound, Just n)] - let bind = Elaboratable_Binding fc lhsFC rig n ty' tm' rest' + let bind = Elaborable_Binding fc lhsFC rig n ty' tm' rest' bd <- get Bang pure $ bindBangs (bangNames bd) ns bind expandDo side ps topfc ns (DoLetPat fc pat ty tm alts :: rest) @@ -806,17 +806,17 @@ mutual bd <- get Bang let fc = virtualiseFC fc pure $ bindBangs (bangNames bd) ns $ - Elaboratable_Case fc [] tm' ty' + Elaborable_Case fc [] tm' ty' (PatClause fc bpat rest' :: alts') expandDo side ps topfc ns (DoLetLocal fc decls :: rest) = do decls' <- traverse (desugarDecl ps) decls rest' <- expandDo side ps topfc ns rest - pure $ Elaboratable_Local_Definitions fc (concat decls') rest' + pure $ Elaborable_Local_Definitions fc (concat decls') rest' expandDo side ps topfc ns (DoRewrite fc rule :: rest) = do rule' <- desugarDo side ps ns rule rest' <- expandDo side ps topfc ns rest - pure $ Elaboratable_Rewrite fc rule' rest' + pure $ Elaborable_Rewrite fc rule' rest' -- Replace all operator by function application desugarTree : Side -> List Name -> Tree (OpStr, Maybe $ OperatorLHSInfo PTerm) PTerm -> @@ -903,11 +903,11 @@ mutual -- - given the pattern 'f x y', getClauseFn would return 'f'. -- - given the pattern 'x == y', getClausefn would return '=='. getClauseFn : RawImp -> Core Name - getClauseFn (Elaboratable_Name _ n) = pure n - getClauseFn (Elaboratable_Apply _ f _) = getClauseFn f - getClauseFn (Elaboratable_With_Apply _ f _) = getClauseFn f - getClauseFn (Elaboratable_Automatic_Apply _ f _) = getClauseFn f - getClauseFn (Elaboratable_Named_Apply _ f _ _) = getClauseFn f + getClauseFn (Elaborable_Name _ n) = pure n + getClauseFn (Elaborable_Apply _ f _) = getClauseFn f + getClauseFn (Elaborable_With_Apply _ f _) = getClauseFn f + getClauseFn (Elaborable_Automatic_Apply _ f _) = getClauseFn f + getClauseFn (Elaborable_Named_Apply _ f _ _) = getClauseFn f getClauseFn tm = throw $ GenericMsg (getFC tm) "Head term in pattern must be a function name" desugarLHS : {auto s : Ref Syn SyntaxInfo} -> @@ -962,7 +962,7 @@ mutual rhs' <- desugar AnyExpr (bound ++ ps) rhs let rhs' = case ws of [] => rhs' - _ => Elaboratable_Local_Definitions fc (concat ws) rhs' + _ => Elaborable_Local_Definitions fc (concat ws) rhs' pure (nm, PatClause fc lhs' rhs') @@ -1007,7 +1007,7 @@ mutual {auto m : Ref MD Metadata} -> {auto o : Ref ROpts REPLOpts} -> List Name -> Namespace -> PField -> - Core (List Elaboratable_Field) + Core (List Elaborable_Field) desugarField ps ns field = flip Core.traverse field.names $ \n : WithFC Name => do addDocStringNS ns n.val field.doc @@ -1101,7 +1101,7 @@ mutual types <- desugarType ps ty pure $ flip (map {f = List, b = ImpDecl}) types $ \ty' => - Elaboratable_Claim (MkFCVal claim.fc $ Make_Elaboratable_Claim_Data rig vis opts ty') + Elaborable_Claim (MkFCVal claim.fc $ Make_Elaborable_Claim_Data rig vis opts ty') desugarDecl ps (MkWithData fc (PDef clauses)) -- The clauses won't necessarily all be from the same function, so split @@ -1112,14 +1112,14 @@ mutual where toIDef : Name -> ImpClause -> Core ImpDecl toIDef nm (PatClause fc lhs rhs) - = pure $ Elaboratable_Definition fc nm [PatClause fc lhs rhs] + = pure $ Elaborable_Definition fc nm [PatClause fc lhs rhs] toIDef nm (WithClause fc lhs rig rhs prf flags cs) - = pure $ Elaboratable_Definition fc nm [WithClause fc lhs rig rhs prf flags cs] + = pure $ Elaborable_Definition fc nm [WithClause fc lhs rig rhs prf flags cs] toIDef nm (ImpossibleClause fc lhs) - = pure $ Elaboratable_Definition fc nm [ImpossibleClause fc lhs] + = pure $ Elaborable_Definition fc nm [ImpossibleClause fc lhs] desugarDecl ps dat@(MkWithData _ $ PData doc vis mbtot ddecl) - = pure [Elaboratable_Data_Declaration dat.fc vis mbtot !(desugarData ps doc ddecl)] + = pure [Elaborable_Data_Declaration dat.fc vis mbtot !(desugarData ps doc ddecl)] desugarDecl ps pp@(MkWithData _ $ PParameters params pds) = do @@ -1134,7 +1134,7 @@ mutual $ findUniqueBindableNames pp.fc True (ps ++ paramNames) [] let paramsb = map {f = List1} (map {f = WithData _} (mapType (doBind pnames))) params' - pure [Elaboratable_Parameter_Block pp.fc paramsb (concat pds')] + pure [Elaborable_Parameter_Block pp.fc paramsb (concat pds')] where getArgs : Either (List1 PlainBinder) (List1 PBinder) -> @@ -1186,7 +1186,7 @@ mutual let consb = map (\ (nm, tm) => (nm, doBind bnames tm)) cons' body' <- traverse (desugarDecl (ps ++ mnames ++ paramNames)) body - pure [Elaboratable_Pragma int.fc (maybe [tn] (\n => [tn, n.val]) conname) + pure [Elaborable_Pragma int.fc (maybe [tn] (\n => [tn, n.val]) conname) (\nest, env => elabInterface int.fc vis env nest consb tn paramsb det conname @@ -1233,7 +1233,7 @@ mutual -- given. let impname = maybe (mkImplName impl.fc tn paramsb) id impln - pure [Elaboratable_Pragma impl.fc [impname] + pure [Elaborable_Pragma impl.fc [impname] (\nest, env => elabImplementation impl.fc vis opts pass env nest isb consb tn paramsb (isNamed impln) @@ -1273,11 +1273,11 @@ mutual let paramsb : List ImpParameter = map (map $ mapType $ doBind bnames) params' let recName = nameRoot tn - fields' : List (List Elaboratable_Field) <- for fields (desugarField (ps ++ fnames ++ paramNames) + fields' : List (List Elaborable_Field) <- for fields (desugarField (ps ++ fnames ++ paramNames) (mkNamespace recName)) let conname : Name = maybe (mkConName tn) val conname_in whenJust (get "doc" <$> conname_in) (addDocString conname) - pure [Elaboratable_Record_Declaration rec.fc (Just recName) + pure [Elaborable_Record_Declaration rec.fc (Just recName) vis mbtot (Mk [rec.fc] $ MkImpRecord (Mk [NoFC tn] paramsb) (Mk [NoFC conname, opts] (concat fields')))] where getfname : PField -> List Name @@ -1359,7 +1359,7 @@ mutual put Ctxt defs -- either fail or return the block that should fail during the elab phase case the (Either (Maybe Error) (List ImpDecl)) result of - Right ds => [Elaboratable_Expected_Failure d.fc mmsg ds] <$ log "desugar.failing" 20 "Success" + Right ds => [Elaborable_Expected_Failure d.fc mmsg ds] <$ log "desugar.failing" 20 "Success" Left Nothing => [] <$ log "desugar.failing" 20 "Correctly failed" Left (Just err) => throw err desugarDecl ps (MkWithData _ $ PMutual ds) @@ -1369,49 +1369,49 @@ mutual desugarDecl ps n@(MkWithData _ $ PNamespace ns decls) = withExtendedNS ns $ do ds <- traverse (desugarDecl ps) decls - pure [Elaboratable_Namespace_Block n.fc ns (concat ds)] + pure [Elaborable_Namespace_Block n.fc ns (concat ds)] desugarDecl ps ts@(MkWithData _ $ PTransform n lhs rhs) = do (bound, blhs) <- bindNames False !(desugar LHS ps lhs) rhs' <- desugar AnyExpr (bound ++ ps) rhs - pure [Elaboratable_Transformation ts.fc (UN $ Basic n) blhs rhs'] + pure [Elaborable_Transformation ts.fc (UN $ Basic n) blhs rhs'] desugarDecl ps el@(MkWithData _ $ PRunElabDecl tm) = do tm' <- desugar AnyExpr ps tm - pure [Elaboratable_Run_Elaborator_Declaration el.fc tm'] + pure [Elaborable_Run_Elaborator_Declaration el.fc tm'] desugarDecl ps dir@(MkWithData _ $ PDirective d) = let fc = dir.fc in case d of - Hide (HideName n) => pure [Elaboratable_Pragma fc [] (\nest, env => hide fc n)] - Hide (HideFixity fx n) => pure [Elaboratable_Pragma fc [] (\_, _ => removeFixity fc fx n)] - Unhide n => pure [Elaboratable_Pragma fc [] (\nest, env => unhide fc n)] - Logging i => pure [Elaboratable_Logging ((\ i => (topics i, verbosity i)) <$> i)] - LazyOn a => pure [Elaboratable_Pragma fc [] (\nest, env => lazyActive a)] + Hide (HideName n) => pure [Elaborable_Pragma fc [] (\nest, env => hide fc n)] + Hide (HideFixity fx n) => pure [Elaborable_Pragma fc [] (\_, _ => removeFixity fc fx n)] + Unhide n => pure [Elaborable_Pragma fc [] (\nest, env => unhide fc n)] + Logging i => pure [Elaborable_Logging ((\ i => (topics i, verbosity i)) <$> i)] + LazyOn a => pure [Elaborable_Pragma fc [] (\nest, env => lazyActive a)] UnboundImplicits a => do setUnboundImplicits a - pure [Elaboratable_Pragma fc [] (\nest, env => setUnboundImplicits a)] + pure [Elaborable_Pragma fc [] (\nest, env => setUnboundImplicits a)] PrefixRecordProjections b => do - pure [Elaboratable_Pragma fc [] (\nest, env => setPrefixRecordProjections b)] - AmbigDepth n => pure [Elaboratable_Pragma fc [] (\nest, env => setAmbigLimit n)] - TotalityDepth n => pure [Elaboratable_Pragma fc [] (\next, env => setTotalLimit n)] - AutoImplicitDepth n => pure [Elaboratable_Pragma fc [] (\nest, env => setAutoImplicitLimit n)] - NFMetavarThreshold n => pure [Elaboratable_Pragma fc [] (\nest, env => setNFThreshold n)] - SearchTimeout n => pure [Elaboratable_Pragma fc [] (\nest, env => setSearchTimeout n)] - PairNames ty f s => pure [Elaboratable_Pragma fc [] (\nest, env => setPair fc ty f s)] - RewriteName eq rw => pure [Elaboratable_Pragma fc [] (\nest, env => setRewrite fc eq rw)] - PrimInteger n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromInteger n)] - PrimString n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromString n)] - PrimChar n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromChar n)] - PrimDouble n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromDouble n)] - PrimTTImp n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromTTImp n)] - PrimName n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromName n)] - PrimDecls n => pure [Elaboratable_Pragma fc [] (\nest, env => setFromDecls n)] - CGAction cg dir => pure [Elaboratable_Pragma fc [] (\nest, env => addDirective cg dir)] - Names n ns => pure [Elaboratable_Pragma fc [] (\nest, env => addNameDirective fc n ns)] - StartExpr tm => pure [Elaboratable_Pragma fc [] (\nest, env => throw (InternalError "%start not implemented"))] -- TODO! - Overloadable n => pure [Elaboratable_Pragma fc [] (\nest, env => setNameFlag fc n Overloadable)] - Extension e => pure [Elaboratable_Pragma fc [] (\nest, env => setExtension e)] - DefaultTotality tot => pure [Elaboratable_Pragma fc [] (\_, _ => setDefaultTotalityOption tot)] + pure [Elaborable_Pragma fc [] (\nest, env => setPrefixRecordProjections b)] + AmbigDepth n => pure [Elaborable_Pragma fc [] (\nest, env => setAmbigLimit n)] + TotalityDepth n => pure [Elaborable_Pragma fc [] (\next, env => setTotalLimit n)] + AutoImplicitDepth n => pure [Elaborable_Pragma fc [] (\nest, env => setAutoImplicitLimit n)] + NFMetavarThreshold n => pure [Elaborable_Pragma fc [] (\nest, env => setNFThreshold n)] + SearchTimeout n => pure [Elaborable_Pragma fc [] (\nest, env => setSearchTimeout n)] + PairNames ty f s => pure [Elaborable_Pragma fc [] (\nest, env => setPair fc ty f s)] + RewriteName eq rw => pure [Elaborable_Pragma fc [] (\nest, env => setRewrite fc eq rw)] + PrimInteger n => pure [Elaborable_Pragma fc [] (\nest, env => setFromInteger n)] + PrimString n => pure [Elaborable_Pragma fc [] (\nest, env => setFromString n)] + PrimChar n => pure [Elaborable_Pragma fc [] (\nest, env => setFromChar n)] + PrimDouble n => pure [Elaborable_Pragma fc [] (\nest, env => setFromDouble n)] + PrimTTImp n => pure [Elaborable_Pragma fc [] (\nest, env => setFromTTImp n)] + PrimName n => pure [Elaborable_Pragma fc [] (\nest, env => setFromName n)] + PrimDecls n => pure [Elaborable_Pragma fc [] (\nest, env => setFromDecls n)] + CGAction cg dir => pure [Elaborable_Pragma fc [] (\nest, env => addDirective cg dir)] + Names n ns => pure [Elaborable_Pragma fc [] (\nest, env => addNameDirective fc n ns)] + StartExpr tm => pure [Elaborable_Pragma fc [] (\nest, env => throw (InternalError "%start not implemented"))] -- TODO! + Overloadable n => pure [Elaborable_Pragma fc [] (\nest, env => setNameFlag fc n Overloadable)] + Extension e => pure [Elaborable_Pragma fc [] (\nest, env => setExtension e)] + DefaultTotality tot => pure [Elaborable_Pragma fc [] (\_, _ => setDefaultTotalityOption tot)] ForeignImpl n cs => do cs' <- traverse (desugar AnyExpr ps) cs - pure [Elaboratable_Pragma fc [] (\nest, env => do + pure [Elaborable_Pragma fc [] (\nest, env => do defs <- get Ctxt calls <- traverse getFnString cs' [(n',_,gdef)] <- lookupCtxtName n (gamma defs) @@ -1422,7 +1422,7 @@ mutual update Ctxt { options->foreignImpl $= (map (n',) calls ++) } )] - desugarDecl ps bt@(MkWithData _ $ PBuiltin type name) = pure [Elaboratable_Builtin_Declaration bt.fc type name] + desugarDecl ps bt@(MkWithData _ $ PBuiltin type name) = pure [Elaborable_Builtin_Declaration bt.fc type name] export desugarDo : {auto s : Ref Syn SyntaxInfo} -> diff --git a/Idris/Elab/Implementation.idr b/Idris/Elab/Implementation.idr index b45d391831..9b24408126 100644 --- a/Idris/Elab/Implementation.idr +++ b/Idris/Elab/Implementation.idr @@ -44,12 +44,12 @@ bindConstraints : FC -> PiInfo RawImp -> List (Maybe Name, RawImp) -> RawImp -> RawImp bindConstraints fc p [] ty = ty bindConstraints fc p ((n, ty) :: rest) sc - = Elaboratable_Dependent_Function_Type fc top p n ty (bindConstraints fc p rest sc) + = Elaborable_Dependent_Function_Type fc top p n ty (bindConstraints fc p rest sc) bindImpls : List (AddFC (ImpParameter' RawImp)) -> RawImp -> RawImp bindImpls [] ty = ty bindImpls (binder :: rest) sc - = Elaboratable_Dependent_Function_Type binder.fc binder.rig binder.val.info (Just binder.nameVal) binder.val.boundType (bindImpls rest sc) + = Elaborable_Dependent_Function_Type binder.fc binder.rig binder.val.info (Just binder.nameVal) binder.val.boundType (bindImpls rest sc) addDefaults : FC -> Name -> (params : List (Name, RawImp)) -> -- parameters have been specialised, use them! @@ -62,7 +62,7 @@ addDefaults fc impName params allms defs body extendBody [] missing body where specialiseMeth : Name -> (Name, RawImp) - specialiseMeth n = (n, Elaboratable_Named_Apply fc (Elaboratable_Name fc n) constructorBindName (Elaboratable_Name fc impName)) + specialiseMeth n = (n, Elaborable_Named_Apply fc (Elaborable_Name fc n) constructorBindName (Elaborable_Name fc impName)) -- Given the list of missing names, if any are among the default definitions, -- add them to the body extendBody : List Name -> List Name -> List ImpDecl -> @@ -86,12 +86,12 @@ addDefaults fc impName params allms defs body let mupdates = params ++ map specialiseMeth allms cs' = map (substNamesClause [] mupdates) cs in extendBody ms ns - (Elaboratable_Definition fc n (map (substLocClause fc) cs') :: body) + (Elaborable_Definition fc n (map (substLocClause fc) cs') :: body) -- Find which names are missing from the body dropGot : List Name -> List ImpDecl -> List Name dropGot ms [] = ms - dropGot ms (Elaboratable_Definition _ n _ :: ds) + dropGot ms (Elaborable_Definition _ n _ :: ds) = dropGot (filter (/= n) ms) ds dropGot ms (_ :: ds) = dropGot ms ds @@ -175,14 +175,14 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i else [Inline, Hint True] let initTy = bindImpls is $ bindConstraints vfc AutoImplicit cons - (apply (Elaboratable_Name vfc iname) ps) + (apply (Elaborable_Name vfc iname) ps) let paramBinds = if !isUnboundImplicits then findBindableNames True varsList [] initTy else [] let impTy = doBind paramBinds initTy let impTyDecl - = Elaboratable_Claim (MkFCVal vfc $ Make_Elaboratable_Claim_Data top vis opts (Mk [EmptyFC, NoFC impName] impTy)) + = Elaborable_Claim (MkFCVal vfc $ Make_Elaborable_Claim_Data top vis opts (Mk [EmptyFC, NoFC impName] impTy)) log "elab.implementation" 5 $ "Implementation type: " ++ show impTy @@ -198,7 +198,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i let None = definition gdef | _ => throw (AlreadyDefined vfc impName) (ty,_) <- elabTerm tidx InType [] nest env - (Elaboratable_Bind_Here vfc (PI erased) impTy) + (Elaborable_Bind_Here vfc (PI erased) impTy) (Just (gType vfc u)) let fullty = abstractFullEnvType vfc env ty ok <- convert defs Env.empty fullty (type gdef) @@ -247,16 +247,16 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i -- 3. Build the record for the implementation let mtops = map (fst . snd) fns let con = iconstructor cdata - let ilhs = impsApply (Elaboratable_Name EmptyFC impName) - (map (\(x, _) => (x, Elaboratable_Bind_Name vfc x)) methImps) + let ilhs = impsApply (Elaborable_Name EmptyFC impName) + (map (\(x, _) => (x, Elaborable_Bind_Name vfc x)) methImps) -- RHS is the constructor applied to a search for the necessary -- parent constraints, then the method implementations defs <- get Ctxt let fldTys = getFieldArgs !(normaliseHoles defs Env.empty conty) log "elab.implementation" 5 $ "Field types " ++ show fldTys - let irhs = apply (autoImpsApply (Elaboratable_Name vfc con) $ map (const (Elaboratable_Search vfc 500)) (parents cdata)) + let irhs = apply (autoImpsApply (Elaborable_Name vfc con) $ map (const (Elaborable_Search vfc 500)) (parents cdata)) (map (mkMethField methImps fldTys) fns) - let impFn = Elaboratable_Definition vfc impName [PatClause vfc ilhs irhs] + let impFn = Elaborable_Definition vfc impName [PatClause vfc ilhs irhs] log "elab.implementation" 5 $ "Implementation record: " ++ show impFn -- If it's a named implementation, add it as a global hint while @@ -326,27 +326,27 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i impsApply : RawImp -> List (Name, RawImp) -> RawImp impsApply fn [] = fn impsApply fn ((n, arg) :: ns) - = impsApply (Elaboratable_Named_Apply vfc fn n arg) ns + = impsApply (Elaborable_Named_Apply vfc fn n arg) ns autoImpsApply : RawImp -> List RawImp -> RawImp autoImpsApply f [] = f - autoImpsApply f (x :: xs) = autoImpsApply (Elaboratable_Automatic_Apply (getFC f) f x) xs + autoImpsApply f (x :: xs) = autoImpsApply (Elaborable_Automatic_Apply (getFC f) f x) xs mkLam : List (Name, RigCount, PiInfo RawImp) -> RawImp -> RawImp mkLam [] tm = tm mkLam ((x, c, p) :: xs) tm - = Elaboratable_Lambda EmptyFC c p (Just x) (Implicit vfc False) (mkLam xs tm) + = Elaborable_Lambda EmptyFC c p (Just x) (Implicit vfc False) (mkLam xs tm) applyTo : RawImp -> List (Name, RigCount, PiInfo RawImp) -> RawImp applyTo tm [] = tm applyTo tm ((x, c, Explicit) :: xs) - = applyTo (Elaboratable_Apply EmptyFC tm (Elaboratable_Name EmptyFC x)) xs + = applyTo (Elaborable_Apply EmptyFC tm (Elaborable_Name EmptyFC x)) xs applyTo tm ((x, c, AutoImplicit) :: xs) - = applyTo (Elaboratable_Named_Apply EmptyFC tm x (Elaboratable_Name EmptyFC x)) xs + = applyTo (Elaborable_Named_Apply EmptyFC tm x (Elaborable_Name EmptyFC x)) xs applyTo tm ((x, c, Implicit) :: xs) - = applyTo (Elaboratable_Named_Apply EmptyFC tm x (Elaboratable_Name EmptyFC x)) xs + = applyTo (Elaborable_Named_Apply EmptyFC tm x (Elaborable_Name EmptyFC x)) xs applyTo tm ((x, c, DefImplicit _) :: xs) - = applyTo (Elaboratable_Named_Apply EmptyFC tm x (Elaboratable_Name EmptyFC x)) xs + = applyTo (Elaborable_Named_Apply EmptyFC tm x (Elaborable_Name EmptyFC x)) xs -- When applying the method in the field for the record, eta expand -- the expected arguments based on the field type, so that implicits get @@ -361,8 +361,8 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i -- implicit arguments to the declaration mkLam argns (impsApply - (applyTo (Elaboratable_Name EmptyFC n) argns) - (map (\n => (n, Elaboratable_Name vfc n)) imps)) + (applyTo (Elaborable_Name EmptyFC n) argns) + (map (\n => (n, Elaborable_Name vfc n)) imps)) where applyUpdate : (Name, RigCount, PiInfo RawImp) -> (Name, RigCount, PiInfo RawImp) @@ -381,14 +381,14 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i applyCon : Name -> Name -> Core (Name, RawImp) applyCon impl n = do mn <- inCurrentNS (methName n) - pure (dropNS n, Elaboratable_Name vfc mn) + pure (dropNS n, Elaborable_Name vfc mn) bindImps : List (Name, RigCount, Maybe RawImp, RawImp) -> RawImp -> RawImp bindImps [] ty = ty bindImps ((n, c, Just def, t) :: ts) ty - = Elaboratable_Dependent_Function_Type vfc c (DefImplicit def) (Just n) t (bindImps ts ty) + = Elaborable_Dependent_Function_Type vfc c (DefImplicit def) (Just n) t (bindImps ts ty) bindImps ((n, c, Nothing, t) :: ts) ty - = Elaboratable_Dependent_Function_Type vfc c Implicit (Just n) t (bindImps ts ty) + = Elaborable_Dependent_Function_Type vfc c Implicit (Just n) t (bindImps ts ty) -- Return method name, specialised method name, implicit name updates, -- and method type. Also return how the method name should be updated @@ -447,8 +447,8 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i log "elab.implementation" 10 $ "Used names " ++ show ibound let ibinds = map fst methImps let methupds' = if isNil ibinds then [] - else [(n, impsApply (Elaboratable_Name vfc n) - (map (\x => (x, Elaboratable_Bind_Name vfc x)) ibinds))] + else [(n, impsApply (Elaborable_Name vfc n) + (map (\x => (x, Elaborable_Bind_Name vfc x)) ibinds))] pure ((meth.nameVal, n, upds, meth.rig, meth.totReq, mty), methupds') @@ -469,7 +469,7 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i = do let opts = if isJust $ findTotality opts_in then opts_in else maybe opts_in (\t => Totality t :: opts_in) treq - Elaboratable_Claim $ MkFCVal vfc $ Make_Elaboratable_Claim_Data c vis opts $ Mk [EmptyFC, NoFC n] mty + Elaborable_Claim $ MkFCVal vfc $ Make_Elaborable_Claim_Data c vis opts $ Mk [EmptyFC, NoFC n] mty -- Given the method type (result of topMethType) return the mapping from -- top level method name to current implementation's method name @@ -488,21 +488,21 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i Just n' => pure n' updateApp : List (Name, Name) -> RawImp -> Core RawImp - updateApp ns (Elaboratable_Name fc n) + updateApp ns (Elaborable_Name fc n) = do n' <- findMethName ns fc n - pure (Elaboratable_Name fc n') - updateApp ns (Elaboratable_Apply fc f arg) + pure (Elaborable_Name fc n') + updateApp ns (Elaborable_Apply fc f arg) = do f' <- updateApp ns f - pure (Elaboratable_Apply fc f' arg) - updateApp ns (Elaboratable_With_Apply fc f arg) + pure (Elaborable_Apply fc f' arg) + updateApp ns (Elaborable_With_Apply fc f arg) = do f' <- updateApp ns f - pure (Elaboratable_With_Apply fc f' arg) - updateApp ns (Elaboratable_Automatic_Apply fc f arg) + pure (Elaborable_With_Apply fc f' arg) + updateApp ns (Elaborable_Automatic_Apply fc f arg) = do f' <- updateApp ns f - pure (Elaboratable_Automatic_Apply fc f' arg) - updateApp ns (Elaboratable_Named_Apply fc f x arg) + pure (Elaborable_Automatic_Apply fc f' arg) + updateApp ns (Elaborable_Named_Apply fc f x arg) = do f' <- updateApp ns f - pure (Elaboratable_Named_Apply fc f' x arg) + pure (Elaborable_Named_Apply fc f' x arg) updateApp ns tm = throw (GenericMsg (getFC tm) "Invalid method definition") @@ -520,11 +520,11 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i pure (ImpossibleClause fc lhs') updateBody : List (Name, Name) -> ImpDecl -> Core ImpDecl - updateBody ns (Elaboratable_Definition fc n cs) + updateBody ns (Elaborable_Definition fc n cs) = do cs' <- traverse (updateClause ns) cs n' <- findMethName ns fc n log "ide-mode.highlight" 1 $ show (n, n', fc) - pure (Elaboratable_Definition fc n' cs') + pure (Elaborable_Definition fc n' cs') updateBody ns e = throw (GenericMsg (getFC e) "Implementation body can only contain definitions") @@ -536,16 +536,16 @@ elabImplementation {vars} ifc vis opts_in pass env nest is cons iname ps named i = do log "elab.implementation" 3 $ "Adding transform for " ++ show meth.nameVal ++ " : " ++ show meth.val ++ "\n\tfor " ++ show iname ++ " in " ++ show ns - let lhs = Elaboratable_Named_Apply vfc (Elaboratable_Name vfc meth.name.val) + let lhs = Elaborable_Named_Apply vfc (Elaborable_Name vfc meth.name.val) constructorBindName - (Elaboratable_Name vfc iname) + (Elaborable_Name vfc iname) let Just mname = lookup (dropNS meth.nameVal) ns | Nothing => pure () - let rhs = Elaboratable_Name vfc mname + let rhs = Elaborable_Name vfc mname log "elab.implementation" 5 $ show lhs ++ " ==> " ++ show rhs handleUnify (processDecl [] nest env - (Elaboratable_Transformation vfc (UN $ Basic (show meth.nameVal ++ " " ++ show iname)) lhs rhs)) + (Elaborable_Transformation vfc (UN $ Basic (show meth.nameVal ++ " " ++ show iname)) lhs rhs)) (\err => log "elab.implementation" 5 $ "Can't add transform " ++ show lhs ++ " ==> " ++ show rhs ++ diff --git a/Idris/Elab/Interface.idr b/Idris/Elab/Interface.idr index 7046fef731..8d16970e80 100644 --- a/Idris/Elab/Interface.idr +++ b/Idris/Elab/Interface.idr @@ -37,26 +37,26 @@ constructorBindName = UN (Basic "__con") -- Give implicit Pi bindings explicit names, if they don't have one already, -- because we need them to be consistent everywhere we refer to them namePis : Int -> RawImp -> RawImp -namePis i (Elaboratable_Dependent_Function_Type fc r info n ty sc) +namePis i (Elaborable_Dependent_Function_Type fc r info n ty sc) = let (n', i') = if isImplicit info && isUnnamed n then (Just (MN "i_con" i), i + 1) else (n, i) - in Elaboratable_Dependent_Function_Type fc r info n' ty (namePis i' sc) + in Elaborable_Dependent_Function_Type fc r info n' ty (namePis i' sc) where isUnnamed : Maybe Name -> Bool isUnnamed = maybe True isUnderscoreName -namePis i (Elaboratable_Bind_Here fc m ty) = Elaboratable_Bind_Here fc m (namePis i ty) +namePis i (Elaborable_Bind_Here fc m ty) = Elaborable_Bind_Here fc m (namePis i ty) namePis i ty = ty getSig : ImpDecl -> Maybe Signature -getSig (Elaboratable_Claim (MkWithData _ $ Make_Elaboratable_Claim_Data c _ opts ty)) +getSig (Elaborable_Claim (MkWithData _ $ Make_Elaborable_Claim_Data c _ opts ty)) = Just $ MkSignature { count = c , flags = opts , name = ty.tyName , isData = False , type = namePis 0 ty.val } -getSig (Elaboratable_Data_Declaration _ _ _ (MkImpLater fc n ty)) +getSig (Elaborable_Data_Declaration _ _ _ (MkImpLater fc n ty)) = Just $ MkSignature { count = erased , flags = [Invertible] , name = NoFC n @@ -72,9 +72,9 @@ getSig _ = Nothing -- TODO: Deal with default superclass implementations mkDataTy : FC -> List (Name, (RigCount, RawImp)) -> RawImp -mkDataTy fc [] = Elaboratable_Type_Universe fc +mkDataTy fc [] = Elaborable_Type_Universe fc mkDataTy fc ((n, (_, ty)) :: ps) - = Elaboratable_Dependent_Function_Type fc top Explicit (Just n) ty (mkDataTy fc ps) + = Elaborable_Dependent_Function_Type fc top Explicit (Just n) ty (mkDataTy fc ps) jname : (Name, (RigCount, RawImp)) -> (Maybe Name, RigCount, RawImp) jname (n, rig, t) = (Just n, rig, t) @@ -83,7 +83,7 @@ mkTy : FC -> PiInfo RawImp -> List (Maybe Name, RigCount, RawImp) -> RawImp -> RawImp mkTy fc imp [] ret = ret mkTy fc imp ((n, c, argty) :: args) ret - = Elaboratable_Dependent_Function_Type fc c imp n argty (mkTy fc imp args ret) + = Elaborable_Dependent_Function_Type fc c imp n argty (mkTy fc imp args ret) mkIfaceData : {vars : _} -> {auto c : Ref Ctxt Defs} -> @@ -95,14 +95,14 @@ mkIfaceData {vars} ifc def_vis env constraints n conName ps dets meths = let opts = [NoHints, UniqueSearch] ++ maybe [] (singleton . SearchBy) dets pNames = map fst ps - retty = apply (Elaboratable_Name vfc n) (map (Elaboratable_Name EmptyFC) pNames) + retty = apply (Elaborable_Name vfc n) (map (Elaborable_Name EmptyFC) pNames) conty = mkTy vfc Implicit (map jname ps) $ mkTy vfc AutoImplicit (map bhere constraints) $ mkTy vfc Explicit (map bname meths) retty con = Mk [vfc, NoFC conName] !(bindTypeNames ifc [] (pNames ++ map fst meths ++ toList vars) conty) bound = pNames ++ map fst meths ++ toList vars in - pure $ Elaboratable_Data_Declaration vfc def_vis Nothing {- ?? -} + pure $ Elaborable_Data_Declaration vfc def_vis Nothing {- ?? -} $ MkImpData vfc n (Just !(bindTypeNames ifc [] bound (mkDataTy vfc ps))) opts [con] @@ -111,10 +111,10 @@ mkIfaceData {vars} ifc def_vis env constraints n conName ps dets meths vfc = virtualiseFC ifc bname : (Name, RigCount, RawImp) -> (Maybe Name, RigCount, RawImp) - bname (n, c, t) = (Just n, c, Elaboratable_Bind_Here (getFC t) (PI erased) t) + bname (n, c, t) = (Just n, c, Elaborable_Bind_Here (getFC t) (PI erased) t) bhere : (Maybe Name, RigCount, RawImp) -> (Maybe Name, RigCount, RawImp) - bhere (n, c, t) = (n, c, Elaboratable_Bind_Here (getFC t) (PI erased) t) + bhere (n, c, t) = (n, c, Elaborable_Bind_Here (getFC t) (PI erased) t) -- Get the implicit arguments for a method declaration or constraint hint -- to allow us to build the data declaration @@ -134,16 +134,16 @@ getMethDecl {vars} env nest params mnames (c, nm, ty) -- type in the record for the interface (they are parameters of the -- interface type), so remove it here stripParams : List Name -> RawImp -> RawImp - stripParams ps (Elaboratable_Dependent_Function_Type fc r p mn arg ret) + stripParams ps (Elaborable_Dependent_Function_Type fc r p mn arg ret) = if (maybe False (\n => n `elem` ps) mn) then stripParams ps ret - else Elaboratable_Dependent_Function_Type fc r p mn arg (stripParams ps ret) + else Elaborable_Dependent_Function_Type fc r p mn arg (stripParams ps ret) stripParams ps ty = ty -- bind the auto implicit for the interface - put it first, as it may be needed -- in other method variables, including implicit variables bindIFace : FC -> RawImp -> RawImp -> RawImp -bindIFace fc ity sc = Elaboratable_Dependent_Function_Type fc top AutoImplicit (Just constructorBindName) ity sc +bindIFace fc ity sc = Elaborable_Dependent_Function_Type fc top AutoImplicit (Just constructorBindName) ity sc -- Get the top level function for implementing a method getMethToplevel : {vars : _} -> @@ -158,23 +158,23 @@ getMethToplevel : {vars : _} -> Core (List ImpDecl) getMethToplevel {vars} env vis iname cname allmeths bindNames params (mname, sig) = do let paramNames = map fst params - let ity = apply (Elaboratable_Name vfc iname) (map (Elaboratable_Name EmptyFC) paramNames) + let ity = apply (Elaborable_Name vfc iname) (map (Elaborable_Name EmptyFC) paramNames) -- Make the constraint application explicit for any method names -- which appear in other method types let ty_constr = substNames (toList vars) (map applyCon allmeths) sig.type ty_imp <- bindTypeNames EmptyFC [] (toList vars) (bindPs params $ bindIFace vfc ity ty_constr) cn <- traverse inCurrentNS sig.name - let tydecl = Elaboratable_Claim (MkFCVal vfc $ Make_Elaboratable_Claim_Data sig.count vis (if sig.isData then [Inline, Invertible] + let tydecl = Elaborable_Claim (MkFCVal vfc $ Make_Elaborable_Claim_Data sig.count vis (if sig.isData then [Inline, Invertible] else [Inline]) (Mk [vfc, cn] ty_imp)) - let conapp = apply (Elaboratable_Name vfc cname) (map (Elaboratable_Bind_Name EmptyFC) bindNames) + let conapp = apply (Elaborable_Name vfc cname) (map (Elaborable_Bind_Name EmptyFC) bindNames) - let lhs = Elaboratable_Named_Apply vfc - (Elaboratable_Name cn.fc cn.val) -- See #3409 + let lhs = Elaborable_Named_Apply vfc + (Elaborable_Name cn.fc cn.val) -- See #3409 constructorBindName conapp - let rhs = Elaboratable_Name EmptyFC mname + let rhs = Elaborable_Name EmptyFC mname -- EtaExpand implicits on both sides: -- First, obtain all the implicit names in the prefix of @@ -182,7 +182,7 @@ getMethToplevel {vars} env vis iname cname allmeths bindNames params (mname, sig (lhs, rhs) <- etaExpandImplicits vfc sig.type lhs rhs let fnclause = PatClause vfc lhs rhs - let fndef = Elaboratable_Definition vfc cn.val [fnclause] + let fndef = Elaborable_Definition vfc cn.val [fnclause] pure [tydecl, fndef] where vfc : FC @@ -193,11 +193,11 @@ getMethToplevel {vars} env vis iname cname allmeths bindNames params (mname, sig bindPs : List (Name, (RigCount, RawImp)) -> RawImp -> RawImp bindPs [] ty = ty bindPs ((n, rig, pty) :: ps) ty - = Elaboratable_Dependent_Function_Type (getFC pty) rig Implicit (Just n) pty (bindPs ps ty) + = Elaborable_Dependent_Function_Type (getFC pty) rig Implicit (Just n) pty (bindPs ps ty) applyCon : Name -> (Name, RawImp) applyCon n - = (n, Elaboratable_Named_Apply vfc (Elaboratable_Name vfc n) constructorBindName (Elaboratable_Name vfc constructorBindName)) + = (n, Elaborable_Named_Apply vfc (Elaborable_Name vfc n) constructorBindName (Elaborable_Name vfc constructorBindName)) -- Get the function for chasing a constraint. This is one of the -- arguments to the record, appearing before the method arguments. @@ -211,33 +211,33 @@ getConstraintHint : {vars : _} -> (Name, RawImp) -> Core (Name, List ImpDecl) getConstraintHint {vars} fc env vis iname cname constraints meths params (cn, con) = do let pNames = map fst params - let ity = apply (Elaboratable_Name fc iname) (map (Elaboratable_Name fc) pNames) + let ity = apply (Elaborable_Name fc iname) (map (Elaborable_Name fc) pNames) let fty = mkTy fc Implicit (map jname params) $ mkTy fc Explicit [(Nothing, top, ity)] con ty_imp <- bindTypeNames fc [] (pNames ++ meths ++ toList vars) fty let hintname = DN ("Constraint " ++ show con) (UN (Basic $ "__" ++ show iname ++ "_" ++ show con)) - let tydecl = Elaboratable_Claim (MkFCVal fc $ Make_Elaboratable_Claim_Data top vis [Inline, Hint False] + let tydecl = Elaborable_Claim (MkFCVal fc $ Make_Elaborable_Claim_Data top vis [Inline, Hint False] (Mk [EmptyFC, NoFC hintname] ty_imp)) - let conapp = apply (impsBind (Elaboratable_Name fc cname) constraints) + let conapp = apply (impsBind (Elaborable_Name fc cname) constraints) (map (const (Implicit fc True)) meths) - let fnclause = PatClause fc (Elaboratable_Apply fc (Elaboratable_Name fc hintname) conapp) - (Elaboratable_Name fc cn) - let fndef = Elaboratable_Definition fc hintname [fnclause] + let fnclause = PatClause fc (Elaborable_Apply fc (Elaborable_Name fc hintname) conapp) + (Elaborable_Name fc cn) + let fndef = Elaborable_Definition fc hintname [fnclause] pure (hintname, [tydecl, fndef]) where impsBind : RawImp -> List Name -> RawImp impsBind fn [] = fn impsBind fn (n :: ns) - = impsBind (Elaboratable_Automatic_Apply fc fn (Elaboratable_Bind_Name fc n)) ns + = impsBind (Elaborable_Automatic_Apply fc fn (Elaborable_Bind_Name fc n)) ns getDefault : ImpDecl -> Maybe (FC, List FnOpt, Name, List ImpClause) -getDefault (Elaboratable_Definition fc n cs) = Just (fc, [], n, cs) +getDefault (Elaborable_Definition fc n cs) = Just (fc, [], n, cs) getDefault _ = Nothing mkCon : FC -> Name -> Name @@ -382,14 +382,14 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod Just d => pure (d.count, d.type) Nothing => throw (GenericMsg dfc ("No method named " ++ show n ++ " in interface " ++ show iname)) - let ity = apply (Elaboratable_Name vdfc iname) (map (Elaboratable_Name vdfc) paramNames) + let ity = apply (Elaborable_Name vdfc iname) (map (Elaborable_Name vdfc) paramNames) -- Substitute the method names with their top level function -- name, so they don't get implicitly bound in the name methNameMap <- traverse (\d => do let n = d.name.val cn <- inCurrentNS n - pure (n, applyParams (Elaboratable_Name vdfc cn) paramNames)) + pure (n, applyParams (Elaborable_Name vdfc cn) paramNames)) tydecls let dty = bindPs params -- bind parameters $ bindIFace vdfc ity -- bind interface (?!) @@ -398,8 +398,8 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod dty_imp <- bindTypeNames dfc [] (map (val . name) tydecls ++ toList vars) dty log "elab.interface.default" 5 $ "Default method " ++ show dn ++ " : " ++ show dty_imp - let dtydecl = Elaboratable_Claim $ MkFCVal vdfc - $ Make_Elaboratable_Claim_Data rig (collapseDefault def_vis) [] + let dtydecl = Elaborable_Claim $ MkFCVal vdfc + $ Make_Elaborable_Claim_Data rig (collapseDefault def_vis) [] $ Mk [EmptyFC, NoFC dn] dty_imp processDecl [] nest env dtydecl @@ -407,7 +407,7 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod cs' <- traverse (changeName dn) cs log "elab.interface.default" 5 $ "Default method body " ++ show cs' - processDecl [] nest env (Elaboratable_Definition vdfc dn cs') + processDecl [] nest env (Elaborable_Definition vdfc dn cs') -- Reset the original context, we don't need to keep the definition -- Actually we do for the metadata and name map! -- put Ctxt orig @@ -421,29 +421,29 @@ elabInterface {vars} ifc def_vis env nest constraints iname params dets mcon bod bindPs : List (Name, (RigCount, RawImp)) -> RawImp -> RawImp bindPs [] ty = ty bindPs ((n, (rig, pty)) :: ps) ty - = Elaboratable_Dependent_Function_Type (getFC pty) rig Implicit (Just n) pty (bindPs ps ty) + = Elaborable_Dependent_Function_Type (getFC pty) rig Implicit (Just n) pty (bindPs ps ty) applyParams : RawImp -> List Name -> RawImp applyParams tm [] = tm applyParams tm (n@(UN (Basic _)) :: ns) - = applyParams (Elaboratable_Named_Apply vdfc tm n (Elaboratable_Bind_Name vdfc n)) ns + = applyParams (Elaborable_Named_Apply vdfc tm n (Elaborable_Bind_Name vdfc n)) ns applyParams tm (_ :: ns) = applyParams tm ns changeNameTerm : Name -> RawImp -> Core RawImp - changeNameTerm dn (Elaboratable_Name fc n') - = do if n /= n' then pure (Elaboratable_Name fc n') else do + changeNameTerm dn (Elaborable_Name fc n') + = do if n /= n' then pure (Elaborable_Name fc n') else do log "ide-mode.highlight" 7 $ "elabDefault is trying to add Function: " ++ show n ++ " (" ++ show fc ++")" whenJust (isConcreteFC fc) $ \nfc => do log "ide-mode.highlight" 7 $ "elabDefault is adding Function: " ++ show n addSemanticDecorations [(nfc, Function, Just n)] - pure (Elaboratable_Name fc dn) - changeNameTerm dn (Elaboratable_Apply fc f arg) - = Elaboratable_Apply fc <$> changeNameTerm dn f <*> pure arg - changeNameTerm dn (Elaboratable_Automatic_Apply fc f arg) - = Elaboratable_Automatic_Apply fc <$> changeNameTerm dn f <*> pure arg - changeNameTerm dn (Elaboratable_Named_Apply fc f x arg) - = Elaboratable_Named_Apply fc <$> changeNameTerm dn f <*> pure x <*> pure arg + pure (Elaborable_Name fc dn) + changeNameTerm dn (Elaborable_Apply fc f arg) + = Elaborable_Apply fc <$> changeNameTerm dn f <*> pure arg + changeNameTerm dn (Elaborable_Automatic_Apply fc f arg) + = Elaborable_Automatic_Apply fc <$> changeNameTerm dn f <*> pure arg + changeNameTerm dn (Elaborable_Named_Apply fc f x arg) + = Elaborable_Named_Apply fc <$> changeNameTerm dn f <*> pure x <*> pure arg changeNameTerm dn tm = pure tm changeName : Name -> ImpClause -> Core ImpClause diff --git a/Idris/REPL.idr b/Idris/REPL.idr index 85316edc41..510db5266c 100644 --- a/Idris/REPL.idr +++ b/Idris/REPL.idr @@ -333,7 +333,7 @@ nextGenDef reject dropLams : Nat -> RawImp' nm -> RawImp' nm dropLams Z tm = tm -dropLams (S k) (Elaboratable_Lambda _ _ _ _ _ sc) = dropLams k sc +dropLams (S k) (Elaborable_Lambda _ _ _ _ _ sc) = dropLams k sc dropLams _ tm = tm dropLamsTm : {vars : _} -> @@ -390,10 +390,10 @@ getItDecls Nothing => pure [] Just n => let it = UN $ Basic "it" in - pure [ Elaboratable_Claim - (MkFCVal replFC $ Make_Elaboratable_Claim_Data top Private [] + pure [ Elaborable_Claim + (MkFCVal replFC $ Make_Elaborable_Claim_Data top Private [] $ Mk [replFC, NoFC it] (Implicit replFC False)) - , Elaboratable_Definition replFC it [PatClause replFC (Elaboratable_Name replFC it) (Elaboratable_Name replFC n)]] + , Elaborable_Definition replFC it [PatClause replFC (Elaborable_Name replFC it) (Elaborable_Name replFC n)]] ||| Produce the elaboration of a PTerm, along with its inferred type inferAndElab : @@ -409,7 +409,7 @@ inferAndElab : Core (TermWithType vars) inferAndElab emode itm env = do ttimp <- desugar AnyExpr (toList vars) itm - let ttimpWithIt = Elaboratable_Local_Definitions replFC !getItDecls ttimp + let ttimpWithIt = Elaborable_Local_Definitions replFC !getItDecls ttimp inidx <- resolveName (UN $ Basic "[input]") -- a TMP HACK to prioritise list syntax for List: hide -- foreign argument lists. TODO: once the new FFI is fully @@ -732,7 +732,7 @@ prepareExp : PTerm -> Core ClosedTerm prepareExp ctm = do ttimp <- desugar AnyExpr [] (PApp replFC (PRef replFC (UN $ Basic "unsafePerformIO")) ctm) - let ttimpWithIt = Elaboratable_Local_Definitions replFC !getItDecls ttimp + let ttimpWithIt = Elaborable_Local_Definitions replFC !getItDecls ttimp inidx <- resolveName (UN $ Basic "[input]") (tm, ty) <- elabTerm inidx InExpr [] (MkNested []) Env.empty ttimpWithIt Nothing diff --git a/Idris/Resugar.idr b/Idris/Resugar.idr index 0687d1d1ed..290d9e8fa4 100644 --- a/Idris/Resugar.idr +++ b/Idris/Resugar.idr @@ -273,15 +273,15 @@ toPRef fc (MkKindedName nt fn nm) = case dropNS nm of mutual toPTerm : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - (prec : Nat) -> Kinded_Elaboratable_Term -> Core IPTerm - toPTerm p (Elaboratable_Name fc nm) = do + (prec : Nat) -> Kinded_Elaborable_Term -> Core IPTerm + toPTerm p (Elaborable_Name fc nm) = do t <- if fullNamespace !(getPPrint) then pure $ PRef fc nm else toPRef fc nm log "resugar.var" 70 $ unwords [ "Resugaring", show @{Raw} nm.rawName, "to", show t] pure t - toPTerm p (Elaboratable_Dependent_Function_Type fc rig Implicit n arg ret) + toPTerm p (Elaborable_Dependent_Function_Type fc rig Implicit n arg ret) = do imp <- showImplicits if imp then do arg' <- toPTerm tyPrec arg @@ -300,12 +300,12 @@ mutual allNs = findAllNames [] ret in (nm `elem` allNs) && not (nm `elem` (map Builtin.fst ns)) needsBind _ = False - toPTerm p (Elaboratable_Dependent_Function_Type fc rig pt n arg ret) + toPTerm p (Elaborable_Dependent_Function_Type fc rig pt n arg ret) = do arg' <- toPTerm appPrec arg ret' <- toPTerm tyPrec ret pt' <- traverse (toPTerm argPrec) pt bracket p tyPrec (PPi fc rig pt' n arg' ret') - toPTerm p (Elaboratable_Lambda fc rig pt mn arg sc) + toPTerm p (Elaborable_Lambda fc rig pt mn arg sc) = do let n = case mn of Nothing => UN Underscore Just n' => n' @@ -316,7 +316,7 @@ mutual pt' <- traverse (toPTerm argPrec) pt let var = PRef fc (MkKindedName (Just Bound) n n) bracket p startPrec (PLam fc rig pt' var arg' sc') - toPTerm p (Elaboratable_Binding fc lhsFC rig n ty val sc) + toPTerm p (Elaborable_Binding fc lhsFC rig n ty val sc) = do imp <- showImplicits ty' <- if imp then toPTerm startPrec ty else pure (PImplicit fc) @@ -324,13 +324,13 @@ mutual sc' <- toPTerm startPrec sc let var = PRef lhsFC (MkKindedName (Just Bound) n n) bracket p startPrec (PLet fc rig var ty' val' sc' []) - toPTerm p (Elaboratable_Case fc _ sc scty [PatClause _ lhs rhs]) + toPTerm p (Elaborable_Case fc _ sc scty [PatClause _ lhs rhs]) = do sc' <- toPTerm startPrec sc lhs' <- toPTerm startPrec lhs rhs' <- toPTerm startPrec rhs bracket p startPrec (PLet fc top lhs' (PImplicit fc) sc' rhs' []) - toPTerm p (Elaboratable_Case fc opts sc scty alts) + toPTerm p (Elaborable_Case fc opts sc scty alts) = do opts' <- traverse toPFnOpt opts sc' <- toPTerm startPrec sc alts' <- traverse toPClause alts @@ -345,65 +345,65 @@ mutual then PIfThenElse loc sc t f else tm mkIf tm = tm - toPTerm p (Elaboratable_Local_Definitions fc ds sc) + toPTerm p (Elaborable_Local_Definitions fc ds sc) = do ds' <- traverse toPDecl ds sc' <- toPTerm startPrec sc bracket p startPrec (PLocal fc (catMaybes ds') sc') - toPTerm p (Elaboratable_Case_Local_Definition fc _ _ _ sc) = toPTerm p sc - toPTerm p (Elaboratable_Record_Update fc ds f) + toPTerm p (Elaborable_Case_Local_Definition fc _ _ _ sc) = toPTerm p sc + toPTerm p (Elaborable_Record_Update fc ds f) = do ds' <- traverse toPFieldUpdate ds f' <- toPTerm argPrec f bracket p startPrec (PApp fc (PUpdate fc ds') f') - toPTerm p (Elaboratable_Apply fc fn arg) + toPTerm p (Elaborable_Apply fc fn arg) = do arg' <- toPTerm argPrec arg app <- toPTermApp fn [(fc, Nothing, arg')] bracket p appPrec app - toPTerm p (Elaboratable_Automatic_Apply fc fn arg) + toPTerm p (Elaborable_Automatic_Apply fc fn arg) = do arg' <- toPTerm argPrec arg app <- toPTermApp fn [(fc, Just Nothing, arg')] bracket p appPrec app - toPTerm p (Elaboratable_With_Apply fc fn arg) + toPTerm p (Elaborable_With_Apply fc fn arg) = do arg' <- toPTerm startPrec arg fn' <- toPTerm startPrec fn bracket p appPrec (PWithApp fc fn' arg') - toPTerm p (Elaboratable_Named_Apply fc fn n arg) + toPTerm p (Elaborable_Named_Apply fc fn n arg) = do arg' <- toPTerm startPrec arg app <- toPTermApp fn [(fc, Just (Just n), arg')] imp <- showImplicits if imp then bracket p startPrec app else mkOp app - toPTerm p (Elaboratable_Search fc d) = pure (PSearch fc d) - toPTerm p (Elaboratable_Alternative fc _ _) = pure (PImplicit fc) - toPTerm p (Elaboratable_Rewrite fc rule tm) + toPTerm p (Elaborable_Search fc d) = pure (PSearch fc d) + toPTerm p (Elaborable_Alternative fc _ _) = pure (PImplicit fc) + toPTerm p (Elaborable_Rewrite fc rule tm) = pure (PRewrite fc !(toPTerm startPrec rule) !(toPTerm startPrec tm)) - toPTerm p (Elaboratable_Coerced fc tm) = toPTerm p tm - toPTerm p (Elaboratable_Primitive_Value fc c) = pure (PPrimVal fc c) - toPTerm p (Elaboratable_Hole fc str) = pure (PHole fc False str) - toPTerm p (Elaboratable_Type_Universe fc) = pure (PType fc) - toPTerm p (Elaboratable_Bind_Name fc nm) + toPTerm p (Elaborable_Coerced fc tm) = toPTerm p tm + toPTerm p (Elaborable_Primitive_Value fc c) = pure (PPrimVal fc c) + toPTerm p (Elaborable_Hole fc str) = pure (PHole fc False str) + toPTerm p (Elaborable_Type_Universe fc) = pure (PType fc) + toPTerm p (Elaborable_Bind_Name fc nm) = pure (PRef fc (MkKindedName (Just Bound) nm nm)) - toPTerm p (Elaboratable_Bind_Here fc _ tm) = toPTerm p tm - toPTerm p (Elaboratable_As_Pattern fc nameFC _ n pat) = pure (PAs fc nameFC n !(toPTerm argPrec pat)) - toPTerm p (Elaboratable_Must_Unify fc r pat) = pure (PDotted fc !(toPTerm argPrec pat)) - - toPTerm p (Elaboratable_Delayed_Type fc r ty) = pure (PDelayed fc r !(toPTerm argPrec ty)) - toPTerm p (Elaboratable_Delay fc tm) = pure (PDelay fc !(toPTerm argPrec tm)) - toPTerm p (Elaboratable_Force fc tm) = pure (PForce fc !(toPTerm argPrec tm)) - toPTerm p (Elaboratable_Quote fc tm) = pure (PQuote fc !(toPTerm argPrec tm)) - toPTerm p (Elaboratable_Quote_Name fc n) = pure (PQuoteName fc n) - toPTerm p (Elaboratable_Quote_Declarations fc ds) + toPTerm p (Elaborable_Bind_Here fc _ tm) = toPTerm p tm + toPTerm p (Elaborable_As_Pattern fc nameFC _ n pat) = pure (PAs fc nameFC n !(toPTerm argPrec pat)) + toPTerm p (Elaborable_Must_Unify fc r pat) = pure (PDotted fc !(toPTerm argPrec pat)) + + toPTerm p (Elaborable_Delayed_Type fc r ty) = pure (PDelayed fc r !(toPTerm argPrec ty)) + toPTerm p (Elaborable_Delay fc tm) = pure (PDelay fc !(toPTerm argPrec tm)) + toPTerm p (Elaborable_Force fc tm) = pure (PForce fc !(toPTerm argPrec tm)) + toPTerm p (Elaborable_Quote fc tm) = pure (PQuote fc !(toPTerm argPrec tm)) + toPTerm p (Elaborable_Quote_Name fc n) = pure (PQuoteName fc n) + toPTerm p (Elaborable_Quote_Declarations fc ds) = do ds' <- traverse toPDecl ds pure $ PQuoteDecl fc (catMaybes ds') - toPTerm p (Elaboratable_Unquote fc tm) = pure (PUnquote fc !(toPTerm argPrec tm)) - toPTerm p (Elaboratable_Run_Elaborator fc _ tm) = pure (PRunElab fc !(toPTerm argPrec tm)) + toPTerm p (Elaborable_Unquote fc tm) = pure (PUnquote fc !(toPTerm argPrec tm)) + toPTerm p (Elaborable_Run_Elaborator fc _ tm) = pure (PRunElab fc !(toPTerm argPrec tm)) - toPTerm p (Elaboratable_Unification_Log fc _ tm) = toPTerm p tm + toPTerm p (Elaborable_Unification_Log fc _ tm) = toPTerm p tm toPTerm p (Implicit fc True) = pure (PImplicit fc) toPTerm p (Implicit fc False) = pure (PInfer fc) - toPTerm p (Elaboratable_With_Unambiguous_Names fc ns rhs) = + toPTerm p (Elaborable_With_Unambiguous_Names fc ns rhs) = PWithUnambigNames fc ns <$> toPTerm startPrec rhs mkApp : {auto c : Ref Ctxt Defs} -> @@ -427,15 +427,15 @@ mutual toPTermApp : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - Kinded_Elaboratable_Term -> List (FC, Maybe (Maybe Name), IPTerm) -> + Kinded_Elaborable_Term -> List (FC, Maybe (Maybe Name), IPTerm) -> Core IPTerm - toPTermApp (Elaboratable_Apply fc f a) args + toPTermApp (Elaborable_Apply fc f a) args = do a' <- toPTerm argPrec a toPTermApp f ((fc, Nothing, a') :: args) - toPTermApp (Elaboratable_Named_Apply fc f n a) args + toPTermApp (Elaborable_Named_Apply fc f n a) args = do a' <- toPTerm startPrec a toPTermApp f ((fc, Just (Just n), a') :: args) - toPTermApp fn@(Elaboratable_Name fc n) args + toPTermApp fn@(Elaborable_Name fc n) args = do defs <- get Ctxt case !(lookupCtxtExact (rawName n) (gamma defs)) of Nothing => do fn' <- toPTerm appPrec fn @@ -453,11 +453,11 @@ mutual toPFieldUpdate : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - Elaboratable_Field_Update' KindedName -> Core (PFieldUpdate' KindedName) - toPFieldUpdate (Elaboratable_Set_Field p v) + Elaborable_Field_Update' KindedName -> Core (PFieldUpdate' KindedName) + toPFieldUpdate (Elaborable_Set_Field p v) = do v' <- toPTerm startPrec v pure (PSetField p v') - toPFieldUpdate (Elaboratable_Apply_To_Field p v) + toPFieldUpdate (Elaborable_Apply_To_Field p v) = do v' <- toPTerm startPrec v pure (PSetFieldApp p v') @@ -494,7 +494,7 @@ mutual toPField : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - Elaboratable_Field' KindedName -> Core (PField' KindedName) + Elaborable_Field' KindedName -> Core (PField' KindedName) toPField field = do bind' <- traverse (toPTerm startPrec) field.val pure (Mk [field.fc , "", field.rig, [field.name]] bind') @@ -510,14 +510,14 @@ mutual toPDecl : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> ImpDecl' KindedName -> Core (Maybe (PDecl' KindedName)) - toPDecl (Elaboratable_Claim (MkWithData fc $ Make_Elaboratable_Claim_Data rig vis opts ty)) + toPDecl (Elaborable_Claim (MkWithData fc $ Make_Elaborable_Claim_Data rig vis opts ty)) = do opts' <- traverse toPFnOpt opts pure (Just (MkWithData fc $ PClaim (MkPClaim rig vis opts' !(toPTypeDecl ty)))) - toPDecl (Elaboratable_Data_Declaration fc vis mbtot d) + toPDecl (Elaborable_Data_Declaration fc vis mbtot d) = pure (Just (MkFCVal fc $ PData "" vis mbtot !(toPData d))) - toPDecl (Elaboratable_Definition fc n cs) + toPDecl (Elaborable_Definition fc n cs) = pure (Just (MkFCVal fc $ PDef !(traverse toPClause cs))) - toPDecl (Elaboratable_Parameter_Block fc ps ds) + toPDecl (Elaborable_Parameter_Block fc ps ds) = do ds' <- traverse toPDecl ds args <- traverseList1 (\binder => @@ -525,7 +525,7 @@ mutual type' <- toPTerm startPrec binder.val.boundType pure (MkFullBinder info' binder.rig binder.name type')) ps pure (Just (MkFCVal fc (PParameters (Right args) (catMaybes ds')))) - toPDecl (Elaboratable_Record_Declaration fc _ vis mbtot (MkWithData _ $ MkImpRecord header body)) + toPDecl (Elaborable_Record_Declaration fc _ vis mbtot (MkWithData _ $ MkImpRecord header body)) = do ps' <- traverse (traverse (traverse (toPTerm startPrec))) header.val fs' <- traverse toPField body.val pure (Just (MkFCVal fc $ PRecord "" vis mbtot @@ -535,21 +535,21 @@ mutual toBinder binder = MkFullBinder binder.val.info binder.rig binder.name binder.val.boundType - toPDecl (Elaboratable_Expected_Failure fc msg ds) + toPDecl (Elaborable_Expected_Failure fc msg ds) = do ds' <- traverse toPDecl ds pure (Just (MkFCVal fc $ PFail msg (catMaybes ds'))) - toPDecl (Elaboratable_Namespace_Block fc ns ds) + toPDecl (Elaborable_Namespace_Block fc ns ds) = do ds' <- traverse toPDecl ds pure (Just (MkFCVal fc $ PNamespace ns (catMaybes ds'))) - toPDecl (Elaboratable_Transformation fc n lhs rhs) + toPDecl (Elaborable_Transformation fc n lhs rhs) = pure (Just (MkFCVal fc $ PTransform (show n) !(toPTerm startPrec lhs) !(toPTerm startPrec rhs))) - toPDecl (Elaboratable_Run_Elaborator_Declaration fc tm) + toPDecl (Elaborable_Run_Elaborator_Declaration fc tm) = pure (Just (MkFCVal fc $ PRunElabDecl !(toPTerm startPrec tm))) - toPDecl (Elaboratable_Pragma {}) = pure Nothing - toPDecl (Elaboratable_Logging _) = pure Nothing - toPDecl (Elaboratable_Builtin_Declaration fc type name) = pure $ Just $ MkFCVal fc $ PBuiltin type name + toPDecl (Elaborable_Pragma {}) = pure Nothing + toPDecl (Elaborable_Logging _) = pure Nothing + toPDecl (Elaborable_Builtin_Declaration fc type name) = pure $ Just $ MkFCVal fc $ PBuiltin type name export cleanPTerm : {auto c : Ref Ctxt Defs} -> @@ -596,7 +596,7 @@ cleanPTerm ptm toCleanPTerm : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - (prec : Nat) -> Kinded_Elaboratable_Term -> Core IPTerm + (prec : Nat) -> Kinded_Elaborable_Term -> Core IPTerm toCleanPTerm prec tti = do ptm <- toPTerm prec tti cleanPTerm ptm @@ -622,5 +622,5 @@ resugarNoPatvars env tm export pterm : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> - Kinded_Elaboratable_Term -> Core IPTerm + Kinded_Elaborable_Term -> Core IPTerm pterm raw = toCleanPTerm startPrec raw diff --git a/Idris/Syntax.idr b/Idris/Syntax.idr index 50777fa671..0ac3a8c63c 100644 --- a/Idris/Syntax.idr +++ b/Idris/Syntax.idr @@ -1098,7 +1098,7 @@ initSyntax initDocStrings [] [] - (Elaboratable_Name EmptyFC (UN $ Basic "main")) + (Elaborable_Name EmptyFC (UN $ Basic "main")) [] where diff --git a/TTIMP_READABLE_NAMES.md b/TTIMP_READABLE_NAMES.md index e656920162..16d10e1d64 100644 --- a/TTIMP_READABLE_NAMES.md +++ b/TTIMP_READABLE_NAMES.md @@ -1,85 +1,85 @@ # Readable TTImp names -This branch spells out the constructor vocabulary of Idris's compiler-internal raw, elaboratable term layer. -`Elaboratable_` replaces the unexplained one-letter constructor prefix and keeps these names distinct from the checked core term constructors. +This branch spells out the constructor vocabulary of Idris's compiler-internal raw, elaborable term layer. +`Elaborable_` replaces the unexplained one-letter constructor prefix and keeps these names distinct from the checked core term constructors. The compiler source itself describes this layer as the raw form which is elaborated into checked core terms. ## Main reading vocabulary | Upstream name | Name on this branch | Meaning | |---|---|---| -| `IVar` | `Elaboratable_Name` | a referenced name | -| `IApp` | `Elaboratable_Apply` | apply one term to another | -| `ILet` | `Elaboratable_Binding` | a local binding | -| `IPi` | `Elaboratable_Dependent_Function_Type` | a function type whose result may depend on its input | -| `ILam` | `Elaboratable_Lambda` | a lambda expression | -| `ICase` | `Elaboratable_Case` | a case expression | +| `IVar` | `Elaborable_Name` | a referenced name | +| `IApp` | `Elaborable_Apply` | apply one term to another | +| `ILet` | `Elaborable_Binding` | a local binding | +| `IPi` | `Elaborable_Dependent_Function_Type` | a function type whose result may depend on its input | +| `ILam` | `Elaborable_Lambda` | a lambda expression | +| `ICase` | `Elaborable_Case` | a case expression | ## Complete compiler-internal rename | Upstream name | Name on this branch | Source occurrences changed | |---|---|---:| -| `IAlternative` | `Elaboratable_Alternative` | 46 | -| `IApp` | `Elaboratable_Apply` | 108 | -| `IArg` | `Kinded_Elaboratable_Argument` | 3 | -| `IAs` | `Elaboratable_As_Pattern` | 59 | -| `IAutoApp` | `Elaboratable_Automatic_Apply` | 82 | -| `IBindHere` | `Elaboratable_Bind_Here` | 35 | -| `IBindVar` | `Elaboratable_Bind_Name` | 54 | -| `IBuiltin` | `Elaboratable_Builtin_Declaration` | 15 | -| `ICase` | `Elaboratable_Case` | 34 | -| `ICaseLocal` | `Elaboratable_Case_Local_Definition` | 15 | -| `IClaim` | `Elaboratable_Claim` | 39 | -| `IClaimData` | `Elaboratable_Claim_Data` | 6 | -| `ICoerced` | `Elaboratable_Coerced` | 21 | -| `IData` | `Elaboratable_Data_Declaration` | 35 | -| `IDef` | `Elaboratable_Definition` | 46 | -| `IDelay` | `Elaboratable_Delay` | 34 | -| `IDelayed` | `Elaboratable_Delayed_Type` | 35 | -| `IFail` | `Elaboratable_Expected_Failure` | 21 | -| `IField` | `Elaboratable_Field` | 15 | -| `IField'` | `Elaboratable_Field'` | 6 | -| `IFieldUpdate` | `Elaboratable_Field_Update` | 16 | -| `IFieldUpdate'` | `Elaboratable_Field_Update'` | 15 | -| `IForce` | `Elaboratable_Force` | 34 | -| `IHole` | `Elaboratable_Hole` | 24 | -| `IImpClause` | `Kinded_Elaboratable_Clause` | 3 | -| `ILam` | `Elaboratable_Lambda` | 61 | -| `ILet` | `Elaboratable_Binding` | 28 | -| `ILocal` | `Elaboratable_Local_Definitions` | 30 | -| `ILog` | `Elaboratable_Logging` | 17 | -| `IMustUnify` | `Elaboratable_Must_Unify` | 39 | -| `INamedApp` | `Elaboratable_Named_Apply` | 101 | -| `INamespace` | `Elaboratable_Namespace_Block` | 29 | -| `IParameters` | `Elaboratable_Parameter_Block` | 22 | -| `IPi` | `Elaboratable_Dependent_Function_Type` | 75 | -| `IPragma` | `Elaboratable_Pragma` | 45 | -| `IPrimVal` | `Elaboratable_Primitive_Value` | 45 | -| `IQuote` | `Elaboratable_Quote` | 25 | -| `IQuoteDecl` | `Elaboratable_Quote_Declarations` | 18 | -| `IQuoteName` | `Elaboratable_Quote_Name` | 17 | -| `IRawImp` | `Kinded_Elaboratable_Term` | 25 | -| `IRecord` | `Elaboratable_Record_Declaration` | 23 | -| `IRewrite` | `Elaboratable_Rewrite` | 22 | -| `IRunElab` | `Elaboratable_Run_Elaborator` | 17 | -| `IRunElabDecl` | `Elaboratable_Run_Elaborator_Declaration` | 14 | -| `ISearch` | `Elaboratable_Search` | 22 | -| `ISetField` | `Elaboratable_Set_Field` | 22 | -| `ISetFieldApp` | `Elaboratable_Apply_To_Field` | 22 | -| `ITransform` | `Elaboratable_Transformation` | 18 | -| `IType` | `Elaboratable_Type_Universe` | 25 | -| `IUnifyLog` | `Elaboratable_Unification_Log` | 13 | -| `IUnquote` | `Elaboratable_Unquote` | 23 | -| `IUpdate` | `Elaboratable_Record_Update` | 35 | -| `IVar` | `Elaboratable_Name` | 206 | -| `IWithApp` | `Elaboratable_With_Apply` | 52 | -| `IWithUnambigNames` | `Elaboratable_With_Unambiguous_Names` | 16 | -| `MkIClaimData` | `Make_Elaboratable_Claim_Data` | 29 | +| `IAlternative` | `Elaborable_Alternative` | 46 | +| `IApp` | `Elaborable_Apply` | 108 | +| `IArg` | `Kinded_Elaborable_Argument` | 3 | +| `IAs` | `Elaborable_As_Pattern` | 59 | +| `IAutoApp` | `Elaborable_Automatic_Apply` | 82 | +| `IBindHere` | `Elaborable_Bind_Here` | 35 | +| `IBindVar` | `Elaborable_Bind_Name` | 54 | +| `IBuiltin` | `Elaborable_Builtin_Declaration` | 15 | +| `ICase` | `Elaborable_Case` | 34 | +| `ICaseLocal` | `Elaborable_Case_Local_Definition` | 15 | +| `IClaim` | `Elaborable_Claim` | 39 | +| `IClaimData` | `Elaborable_Claim_Data` | 6 | +| `ICoerced` | `Elaborable_Coerced` | 21 | +| `IData` | `Elaborable_Data_Declaration` | 35 | +| `IDef` | `Elaborable_Definition` | 46 | +| `IDelay` | `Elaborable_Delay` | 34 | +| `IDelayed` | `Elaborable_Delayed_Type` | 35 | +| `IFail` | `Elaborable_Expected_Failure` | 21 | +| `IField` | `Elaborable_Field` | 15 | +| `IField'` | `Elaborable_Field'` | 6 | +| `IFieldUpdate` | `Elaborable_Field_Update` | 16 | +| `IFieldUpdate'` | `Elaborable_Field_Update'` | 15 | +| `IForce` | `Elaborable_Force` | 34 | +| `IHole` | `Elaborable_Hole` | 24 | +| `IImpClause` | `Kinded_Elaborable_Clause` | 3 | +| `ILam` | `Elaborable_Lambda` | 61 | +| `ILet` | `Elaborable_Binding` | 28 | +| `ILocal` | `Elaborable_Local_Definitions` | 30 | +| `ILog` | `Elaborable_Logging` | 17 | +| `IMustUnify` | `Elaborable_Must_Unify` | 39 | +| `INamedApp` | `Elaborable_Named_Apply` | 101 | +| `INamespace` | `Elaborable_Namespace_Block` | 29 | +| `IParameters` | `Elaborable_Parameter_Block` | 22 | +| `IPi` | `Elaborable_Dependent_Function_Type` | 75 | +| `IPragma` | `Elaborable_Pragma` | 45 | +| `IPrimVal` | `Elaborable_Primitive_Value` | 45 | +| `IQuote` | `Elaborable_Quote` | 25 | +| `IQuoteDecl` | `Elaborable_Quote_Declarations` | 18 | +| `IQuoteName` | `Elaborable_Quote_Name` | 17 | +| `IRawImp` | `Kinded_Elaborable_Term` | 25 | +| `IRecord` | `Elaborable_Record_Declaration` | 23 | +| `IRewrite` | `Elaborable_Rewrite` | 22 | +| `IRunElab` | `Elaborable_Run_Elaborator` | 17 | +| `IRunElabDecl` | `Elaborable_Run_Elaborator_Declaration` | 14 | +| `ISearch` | `Elaborable_Search` | 22 | +| `ISetField` | `Elaborable_Set_Field` | 22 | +| `ISetFieldApp` | `Elaborable_Apply_To_Field` | 22 | +| `ITransform` | `Elaborable_Transformation` | 18 | +| `IType` | `Elaborable_Type_Universe` | 25 | +| `IUnifyLog` | `Elaborable_Unification_Log` | 13 | +| `IUnquote` | `Elaborable_Unquote` | 23 | +| `IUpdate` | `Elaborable_Record_Update` | 35 | +| `IVar` | `Elaborable_Name` | 206 | +| `IWithApp` | `Elaborable_With_Apply` | 52 | +| `IWithUnambigNames` | `Elaborable_With_Unambiguous_Names` | 16 | +| `MkIClaimData` | `Make_Elaborable_Claim_Data` | 29 | | `findIBinds` | `find_names_to_bind` | 49 | -| `isIBindVar` | `is_elaboratable_bound_name` | 4 | +| `isIBindVar` | `is_elaborable_bound_name` | 4 | | `isIPrimVal` | `is_primitive_value` | 4 | -| `isIVar` | `is_elaboratable_name` | 4 | -| `unIArg` | `elaboratable_argument_term` | 4 | +| `isIVar` | `is_elaborable_name` | 4 | +| `unIArg` | `elaborable_argument_term` | 4 | ## Reflection compatibility boundary diff --git a/TTImp/BindImplicits.idr b/TTImp/BindImplicits.idr index 9a69a129ff..8ff94ebb3e 100644 --- a/TTImp/BindImplicits.idr +++ b/TTImp/BindImplicits.idr @@ -16,105 +16,105 @@ export renameIBinds : (renames : List String) -> (used : List String) -> RawImp -> State (List (String, String)) RawImp -renameIBinds rs us (Elaboratable_Dependent_Function_Type fc c p (Just un@(UN (Basic n))) ty sc) +renameIBinds rs us (Elaborable_Dependent_Function_Type fc c p (Just un@(UN (Basic n))) ty sc) = if n `elem` rs then let n' = genUniqueStr (rs ++ us) n un' = UN (Basic n') sc' = substNames (map (UN . Basic) (filter (/= n) us)) - [(un, Elaboratable_Name fc un')] sc in + [(un, Elaborable_Name fc un')] sc in do scr <- renameIBinds rs (n' :: us) sc' ty' <- renameIBinds rs us ty upds <- get put ((n, n') :: upds) - pure $ Elaboratable_Dependent_Function_Type fc c p (Just un') ty' scr + pure $ Elaborable_Dependent_Function_Type fc c p (Just un') ty' scr else do scr <- renameIBinds rs us sc ty' <- renameIBinds rs us ty - pure $ Elaboratable_Dependent_Function_Type fc c p (Just un) ty' scr -renameIBinds rs us (Elaboratable_Dependent_Function_Type fc c p n ty sc) - = pure $ Elaboratable_Dependent_Function_Type fc c p n !(renameIBinds rs us ty) !(renameIBinds rs us sc) -renameIBinds rs us (Elaboratable_Lambda fc c p n ty sc) - = pure $ Elaboratable_Lambda fc c p n !(renameIBinds rs us ty) !(renameIBinds rs us sc) -renameIBinds rs us (Elaboratable_Apply fc fn arg) - = pure $ Elaboratable_Apply fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) -renameIBinds rs us (Elaboratable_Automatic_Apply fc fn arg) - = pure $ Elaboratable_Automatic_Apply fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) -renameIBinds rs us (Elaboratable_Named_Apply fc fn n arg) - = pure $ Elaboratable_Named_Apply fc !(renameIBinds rs us fn) n !(renameIBinds rs us arg) -renameIBinds rs us (Elaboratable_With_Apply fc fn arg) - = pure $ Elaboratable_With_Apply fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) -renameIBinds rs us (Elaboratable_As_Pattern fc nameFC s n pat) - = pure $ Elaboratable_As_Pattern fc nameFC s n !(renameIBinds rs us pat) -renameIBinds rs us (Elaboratable_Must_Unify fc r pat) - = pure $ Elaboratable_Must_Unify fc r !(renameIBinds rs us pat) -renameIBinds rs us (Elaboratable_Delayed_Type fc r t) - = pure $ Elaboratable_Delayed_Type fc r !(renameIBinds rs us t) -renameIBinds rs us (Elaboratable_Delay fc t) - = pure $ Elaboratable_Delay fc !(renameIBinds rs us t) -renameIBinds rs us (Elaboratable_Force fc t) - = pure $ Elaboratable_Force fc !(renameIBinds rs us t) -renameIBinds rs us (Elaboratable_Record_Update fc updates tm) - = pure $ Elaboratable_Record_Update fc !(traverse f updates) !(renameIBinds rs us tm) + pure $ Elaborable_Dependent_Function_Type fc c p (Just un) ty' scr +renameIBinds rs us (Elaborable_Dependent_Function_Type fc c p n ty sc) + = pure $ Elaborable_Dependent_Function_Type fc c p n !(renameIBinds rs us ty) !(renameIBinds rs us sc) +renameIBinds rs us (Elaborable_Lambda fc c p n ty sc) + = pure $ Elaborable_Lambda fc c p n !(renameIBinds rs us ty) !(renameIBinds rs us sc) +renameIBinds rs us (Elaborable_Apply fc fn arg) + = pure $ Elaborable_Apply fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) +renameIBinds rs us (Elaborable_Automatic_Apply fc fn arg) + = pure $ Elaborable_Automatic_Apply fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) +renameIBinds rs us (Elaborable_Named_Apply fc fn n arg) + = pure $ Elaborable_Named_Apply fc !(renameIBinds rs us fn) n !(renameIBinds rs us arg) +renameIBinds rs us (Elaborable_With_Apply fc fn arg) + = pure $ Elaborable_With_Apply fc !(renameIBinds rs us fn) !(renameIBinds rs us arg) +renameIBinds rs us (Elaborable_As_Pattern fc nameFC s n pat) + = pure $ Elaborable_As_Pattern fc nameFC s n !(renameIBinds rs us pat) +renameIBinds rs us (Elaborable_Must_Unify fc r pat) + = pure $ Elaborable_Must_Unify fc r !(renameIBinds rs us pat) +renameIBinds rs us (Elaborable_Delayed_Type fc r t) + = pure $ Elaborable_Delayed_Type fc r !(renameIBinds rs us t) +renameIBinds rs us (Elaborable_Delay fc t) + = pure $ Elaborable_Delay fc !(renameIBinds rs us t) +renameIBinds rs us (Elaborable_Force fc t) + = pure $ Elaborable_Force fc !(renameIBinds rs us t) +renameIBinds rs us (Elaborable_Record_Update fc updates tm) + = pure $ Elaborable_Record_Update fc !(traverse f updates) !(renameIBinds rs us tm) where - f : Elaboratable_Field_Update -> State (List (String, String)) Elaboratable_Field_Update - f (Elaboratable_Set_Field path x) = Elaboratable_Set_Field path <$> renameIBinds rs us x - f (Elaboratable_Apply_To_Field path x) = Elaboratable_Apply_To_Field path <$> renameIBinds rs us x -renameIBinds rs us (Elaboratable_Alternative fc u alts) - = pure $ Elaboratable_Alternative fc !(renameAlt u) + f : Elaborable_Field_Update -> State (List (String, String)) Elaborable_Field_Update + f (Elaborable_Set_Field path x) = Elaborable_Set_Field path <$> renameIBinds rs us x + f (Elaborable_Apply_To_Field path x) = Elaborable_Apply_To_Field path <$> renameIBinds rs us x +renameIBinds rs us (Elaborable_Alternative fc u alts) + = pure $ Elaborable_Alternative fc !(renameAlt u) !(traverse (renameIBinds rs us) alts) where renameAlt : AltType -> State (List (String, String)) AltType renameAlt (UniqueDefault t) = pure $ UniqueDefault !(renameIBinds rs us t) renameAlt u = pure u -renameIBinds rs us (Elaboratable_Bind_Name fc nm@(UN (Basic n))) +renameIBinds rs us (Elaborable_Bind_Name fc nm@(UN (Basic n))) = if n `elem` rs then do let n' = genUniqueStr (rs ++ us) n upds <- get put ((n, n') :: upds) - pure $ Elaboratable_Bind_Name fc (UN (Basic n')) - else pure $ Elaboratable_Bind_Name fc nm + pure $ Elaborable_Bind_Name fc (UN (Basic n')) + else pure $ Elaborable_Bind_Name fc nm renameIBinds rs us tm = pure $ tm export doBind : List (Name, Name) -> RawImp -> RawImp doBind [] tm = tm -doBind ns (Elaboratable_Name fc nm) - = maybe (Elaboratable_Name fc nm) (Elaboratable_Bind_Name fc) (lookup nm ns) -doBind ns (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) +doBind ns (Elaborable_Name fc nm) + = maybe (Elaborable_Name fc nm) (Elaborable_Bind_Name fc) (lookup nm ns) +doBind ns (Elaborable_Dependent_Function_Type fc rig p mn aty retty) = let ns' = case mn of Just nm => filter (\x => fst x /= nm) ns _ => ns in - Elaboratable_Dependent_Function_Type fc rig p mn (doBind ns' aty) (doBind ns' retty) -doBind ns (Elaboratable_Lambda fc rig p mn aty sc) + Elaborable_Dependent_Function_Type fc rig p mn (doBind ns' aty) (doBind ns' retty) +doBind ns (Elaborable_Lambda fc rig p mn aty sc) = let ns' = case mn of Just nm => filter (\x => fst x /= nm) ns _ => ns in - Elaboratable_Lambda fc rig p mn (doBind ns' aty) (doBind ns' sc) -doBind ns (Elaboratable_Apply fc fn av) - = Elaboratable_Apply fc (doBind ns fn) (doBind ns av) -doBind ns (Elaboratable_Automatic_Apply fc fn av) - = Elaboratable_Automatic_Apply fc (doBind ns fn) (doBind ns av) -doBind ns (Elaboratable_Named_Apply fc fn n av) - = Elaboratable_Named_Apply fc (doBind ns fn) n (doBind ns av) -doBind ns (Elaboratable_With_Apply fc fn av) - = Elaboratable_With_Apply fc (doBind ns fn) (doBind ns av) -doBind ns (Elaboratable_As_Pattern fc nameFC s n pat) - = Elaboratable_As_Pattern fc nameFC s n (doBind ns pat) -doBind ns (Elaboratable_Must_Unify fc r pat) - = Elaboratable_Must_Unify fc r (doBind ns pat) -doBind ns (Elaboratable_Delayed_Type fc r ty) - = Elaboratable_Delayed_Type fc r (doBind ns ty) -doBind ns (Elaboratable_Delay fc tm) - = Elaboratable_Delay fc (doBind ns tm) -doBind ns (Elaboratable_Force fc tm) - = Elaboratable_Force fc (doBind ns tm) -doBind ns (Elaboratable_Quote fc tm) - = Elaboratable_Quote fc (doBind ns tm) -doBind ns (Elaboratable_Unquote fc tm) - = Elaboratable_Unquote fc (doBind ns tm) -doBind ns (Elaboratable_Alternative fc u alts) - = Elaboratable_Alternative fc (mapAltType (doBind ns) u) (map (doBind ns) alts) -doBind ns (Elaboratable_Record_Update fc updates tm) - = Elaboratable_Record_Update fc (map (mapFieldUpdateTerm $ doBind ns) updates) (doBind ns tm) + Elaborable_Lambda fc rig p mn (doBind ns' aty) (doBind ns' sc) +doBind ns (Elaborable_Apply fc fn av) + = Elaborable_Apply fc (doBind ns fn) (doBind ns av) +doBind ns (Elaborable_Automatic_Apply fc fn av) + = Elaborable_Automatic_Apply fc (doBind ns fn) (doBind ns av) +doBind ns (Elaborable_Named_Apply fc fn n av) + = Elaborable_Named_Apply fc (doBind ns fn) n (doBind ns av) +doBind ns (Elaborable_With_Apply fc fn av) + = Elaborable_With_Apply fc (doBind ns fn) (doBind ns av) +doBind ns (Elaborable_As_Pattern fc nameFC s n pat) + = Elaborable_As_Pattern fc nameFC s n (doBind ns pat) +doBind ns (Elaborable_Must_Unify fc r pat) + = Elaborable_Must_Unify fc r (doBind ns pat) +doBind ns (Elaborable_Delayed_Type fc r ty) + = Elaborable_Delayed_Type fc r (doBind ns ty) +doBind ns (Elaborable_Delay fc tm) + = Elaborable_Delay fc (doBind ns tm) +doBind ns (Elaborable_Force fc tm) + = Elaborable_Force fc (doBind ns tm) +doBind ns (Elaborable_Quote fc tm) + = Elaborable_Quote fc (doBind ns tm) +doBind ns (Elaborable_Unquote fc tm) + = Elaborable_Unquote fc (doBind ns tm) +doBind ns (Elaborable_Alternative fc u alts) + = Elaborable_Alternative fc (mapAltType (doBind ns) u) (map (doBind ns) alts) +doBind ns (Elaborable_Record_Update fc updates tm) + = Elaborable_Record_Update fc (map (mapFieldUpdateTerm $ doBind ns) updates) (doBind ns tm) doBind ns tm = tm export @@ -152,7 +152,7 @@ getUsings ns u = concatMap (flip getUsing u) ns bindUsings : List (RigCount, PiInfo RawImp, Maybe Name, RawImp) -> RawImp -> RawImp bindUsings [] tm = tm bindUsings ((rig, p, mn, ty) :: us) tm - = Elaboratable_Dependent_Function_Type (getFC ty) rig p mn ty (bindUsings us tm) + = Elaborable_Dependent_Function_Type (getFC ty) rig p mn ty (bindUsings us tm) addUsing : List (Maybe Name, RawImp) -> RawImp -> RawImp @@ -195,5 +195,5 @@ piBindNames loc env tm piBind : List Name -> RawImp -> RawImp piBind [] ty = ty piBind (n :: ns) ty - = Elaboratable_Dependent_Function_Type loc erased Implicit (Just n) (Implicit loc False) + = Elaborable_Dependent_Function_Type loc erased Implicit (Just n) (Implicit loc False) $ piBind ns ty diff --git a/TTImp/Elab.idr b/TTImp/Elab.idr index 2a9796dde6..0fa187afd7 100644 --- a/TTImp/Elab.idr +++ b/TTImp/Elab.idr @@ -260,13 +260,13 @@ checkTermSub defining mode opts nest env env' sub tm ty Core RawImp bindImps' loc env [] ty = pure ty bindImps' loc env ((n, ty) :: ntys) sc - = pure $ Elaboratable_Dependent_Function_Type loc erased Implicit (Just n) + = pure $ Elaborable_Dependent_Function_Type loc erased Implicit (Just n) (Implicit loc True) !(bindImps' loc env ntys sc) bindImps : FC -> Env Term vs -> List (Name, Term vs) -> RawImp -> Core RawImp - bindImps loc env ns (Elaboratable_Bind_Here fc m ty) - = pure $ Elaboratable_Bind_Here fc m !(bindImps' loc env ns ty) + bindImps loc env ns (Elaborable_Bind_Here fc m ty) + = pure $ Elaborable_Bind_Here fc m !(bindImps' loc env ns ty) bindImps loc env ns ty = bindImps' loc env ns ty export diff --git a/TTImp/Elab/Ambiguity.idr b/TTImp/Elab/Ambiguity.idr index 4f496ff1db..eb5459f476 100644 --- a/TTImp/Elab/Ambiguity.idr +++ b/TTImp/Elab/Ambiguity.idr @@ -27,12 +27,12 @@ expandAmbigName : {vars : _} -> ElabMode -> NestedNames vars -> Env Term vars -> RawImp -> List (FC, Maybe (Maybe Name), RawImp) -> RawImp -> Maybe (Glued vars) -> Core RawImp -expandAmbigName (InLHS _) nest env orig args (Elaboratable_Bind_Name fc n) exp +expandAmbigName (InLHS _) nest env orig args (Elaborable_Bind_Name fc n) exp = do est <- get EST if n `elem` lhsPatVars est - then pure $ Elaboratable_Must_Unify fc NonLinearVar orig + then pure $ Elaborable_Must_Unify fc NonLinearVar orig else pure $ orig -expandAmbigName mode nest env orig args (Elaboratable_Name fc x) exp +expandAmbigName mode nest env orig args (Elaborable_Name fc x) exp = case lookup x (names nest) of Just _ => do log "elab.ambiguous" 20 $ "Nested " ++ show x pure orig @@ -43,7 +43,7 @@ expandAmbigName mode nest env orig args (Elaboratable_Name fc x) exp if isNil args || notLHS mode then do log "elab.ambiguous" 20 $ "Defined in env " ++ show x pure $ orig - else pure $ Elaboratable_Must_Unify fc VarApplied orig + else pure $ Elaborable_Must_Unify fc VarApplied orig Nothing => do est <- get EST primNs <- getPrimNames @@ -65,7 +65,7 @@ expandAmbigName mode nest env orig args (Elaboratable_Name fc x) exp nalts => do log "elab.ambiguous" 10 $ "Ambiguous: " ++ joinBy ", " (map (show . fst) nalts) - pure $ Elaboratable_Alternative fc + pure $ Elaborable_Alternative fc (uniqType x args primNs) (map (mkAlt primApp est) nalts) where @@ -86,21 +86,21 @@ expandAmbigName mode nest env orig args (Elaboratable_Name fc x) exp -- the primitive directly -- The order of the arguments have a big effect on case-tree size uniqType : Name -> List (FC, Maybe (Maybe Name), RawImp) -> PrimNames -> AltType - uniqType n [(_, _, Elaboratable_Primitive_Value fc (BI x))] (MkPrimNs (Just fi) _ _ _ _ _ _) - = UniqueDefault (Elaboratable_Primitive_Value fc (BI x)) - uniqType n [(_, _, Elaboratable_Primitive_Value fc (Str x))] (MkPrimNs _ (Just si) _ _ _ _ _) - = UniqueDefault (Elaboratable_Primitive_Value fc (Str x)) - uniqType n [(_, _, Elaboratable_Primitive_Value fc (Ch x))] (MkPrimNs _ _ (Just ci) _ _ _ _) - = UniqueDefault (Elaboratable_Primitive_Value fc (Ch x)) - uniqType n [(_, _, Elaboratable_Primitive_Value fc (Db x))] (MkPrimNs _ _ _ (Just di) _ _ _) - = UniqueDefault (Elaboratable_Primitive_Value fc (Db x)) - uniqType n [(_, _, Elaboratable_Quote fc tm)] (MkPrimNs _ _ _ _ (Just dt) _ _) - = UniqueDefault (Elaboratable_Quote fc tm) + uniqType n [(_, _, Elaborable_Primitive_Value fc (BI x))] (MkPrimNs (Just fi) _ _ _ _ _ _) + = UniqueDefault (Elaborable_Primitive_Value fc (BI x)) + uniqType n [(_, _, Elaborable_Primitive_Value fc (Str x))] (MkPrimNs _ (Just si) _ _ _ _ _) + = UniqueDefault (Elaborable_Primitive_Value fc (Str x)) + uniqType n [(_, _, Elaborable_Primitive_Value fc (Ch x))] (MkPrimNs _ _ (Just ci) _ _ _ _) + = UniqueDefault (Elaborable_Primitive_Value fc (Ch x)) + uniqType n [(_, _, Elaborable_Primitive_Value fc (Db x))] (MkPrimNs _ _ _ (Just di) _ _ _) + = UniqueDefault (Elaborable_Primitive_Value fc (Db x)) + uniqType n [(_, _, Elaborable_Quote fc tm)] (MkPrimNs _ _ _ _ (Just dt) _ _) + = UniqueDefault (Elaborable_Quote fc tm) {- - uniqType n [(_, _, Elaboratable_Quote_Name fc tm)] (MkPrimNs _ _ _ _ _ (Just dn) _) - = UniqueDefault (Elaboratable_Quote_Name fc tm) - uniqType n [(_, _, Elaboratable_Quote_Declarations fc tm)] (MkPrimNs _ _ _ _ _ _ (Just ddl)) - = UniqueDefault (Elaboratable_Quote_Declarations fc tm) + uniqType n [(_, _, Elaborable_Quote_Name fc tm)] (MkPrimNs _ _ _ _ _ (Just dn) _) + = UniqueDefault (Elaborable_Quote_Name fc tm) + uniqType n [(_, _, Elaborable_Quote_Declarations fc tm)] (MkPrimNs _ _ _ _ _ _ (Just ddl)) + = UniqueDefault (Elaborable_Quote_Declarations fc tm) -} uniqType _ _ _ = Unique @@ -108,11 +108,11 @@ expandAmbigName mode nest env orig args (Elaboratable_Name fc x) exp RawImp buildAlt f [] = f buildAlt f ((fc', Nothing, a) :: as) - = buildAlt (Elaboratable_Apply fc' f a) as + = buildAlt (Elaborable_Apply fc' f a) as buildAlt f ((fc', Just Nothing, a) :: as) - = buildAlt (Elaboratable_Automatic_Apply fc' f a) as + = buildAlt (Elaborable_Automatic_Apply fc' f a) as buildAlt f ((fc', Just (Just i), a) :: as) - = buildAlt (Elaboratable_Named_Apply fc' f i a) as + = buildAlt (Elaborable_Named_Apply fc' f i a) as -- If it's not a constructor application, dot it wrapDot : Bool -> EState vars -> @@ -124,11 +124,11 @@ expandAmbigName mode nest env orig args (Elaboratable_Name fc x) exp wrapDot prim est (InLHS _) n' [arg] _ tm = if n' == Resolved (defining est) || prim then tm - else Elaboratable_Must_Unify fc NotConstructor tm + else Elaborable_Must_Unify fc NotConstructor tm wrapDot prim est (InLHS _) n' _ _ tm = if n' == Resolved (defining est) then tm - else Elaboratable_Must_Unify fc NotConstructor tm + else Elaborable_Must_Unify fc NotConstructor tm wrapDot _ _ _ _ _ _ tm = tm notLHS : ElabMode -> Bool @@ -140,9 +140,9 @@ expandAmbigName mode nest env orig args (Elaboratable_Name fc x) exp = if (Context.Macro `elem` flags def) && notLHS mode then alternativeFirstSuccess $ reverse $ allSplits args <&> \(macroArgs, extArgs) => - (Elaboratable_Run_Elaborator fc False $ Elaboratable_Coerced fc $ Elaboratable_Name fc n `buildAlt` macroArgs) `buildAlt` extArgs + (Elaborable_Run_Elaborator fc False $ Elaborable_Coerced fc $ Elaborable_Name fc n `buildAlt` macroArgs) `buildAlt` extArgs else wrapDot prim est mode n (map (snd . snd) args) - (definition def) (buildAlt (Elaboratable_Name fc n) args) + (definition def) (buildAlt (Elaborable_Name fc n) args) where -- All splits of the original list starting from the (empty, full) finishing with (full, empty) allSplits : (l : List a) -> Vect (S $ length l) (List a, List a) @@ -151,19 +151,19 @@ expandAmbigName mode nest env orig args (Elaboratable_Name fc x) exp alternativeFirstSuccess : forall n. Vect (S n) RawImp -> RawImp alternativeFirstSuccess [x] = x - alternativeFirstSuccess xs = Elaboratable_Alternative fc FirstSuccess $ toList xs + alternativeFirstSuccess xs = Elaborable_Alternative fc FirstSuccess $ toList xs mkAlt : Bool -> EState vars -> (Name, Int, GlobalDef) -> RawImp mkAlt prim est (fullname, i, gdef) = mkTerm prim est (Resolved i) gdef -expandAmbigName mode nest env orig args (Elaboratable_Apply fc f a) exp +expandAmbigName mode nest env orig args (Elaborable_Apply fc f a) exp = expandAmbigName mode nest env orig ((fc, Nothing, a) :: args) f exp -expandAmbigName mode nest env orig args (Elaboratable_Named_Apply fc f n a) exp +expandAmbigName mode nest env orig args (Elaborable_Named_Apply fc f n a) exp = expandAmbigName mode nest env orig ((fc, Just (Just n), a) :: args) f exp -expandAmbigName mode nest env orig args (Elaboratable_Automatic_Apply fc f a) exp +expandAmbigName mode nest env orig args (Elaborable_Automatic_Apply fc f a) exp = expandAmbigName mode nest env orig ((fc, Just Nothing, a) :: args) f exp expandAmbigName elabmode nest env orig args tm exp @@ -248,8 +248,8 @@ couldBeName defs target n couldBeFn : {auto c : Ref Ctxt Defs} -> {vars : _} -> Defs -> NF vars -> RawImp -> Core TypeMatch -couldBeFn defs ty (Elaboratable_Name _ n) = couldBeName defs ty n -couldBeFn defs ty (Elaboratable_Alternative {}) = pure Concrete +couldBeFn defs ty (Elaborable_Name _ n) = couldBeName defs ty n +couldBeFn defs ty (Elaborable_Alternative {}) = pure Concrete couldBeFn defs ty _ = pure Poly -- Returns Nothing if there's no possibility the expression's type matches @@ -282,7 +282,7 @@ notOverloadable defs (True, fn) = pure True notOverloadable defs (concrete, fn) = notOverloadableFn (getFn fn) where notOverloadableFn : RawImp -> Core Bool - notOverloadableFn (Elaboratable_Name _ n) + notOverloadableFn (Elaborable_Name _ n) = do Just gdef <- lookupCtxtExact n (gamma defs) | Nothing => pure True pure False -- If the name exists, and doesn't have a concrete type @@ -332,10 +332,10 @@ checkAmbigDepth fc info throw (AmbiguityTooDeep fc (Resolved (defining est)) ambs) getName : RawImp -> Maybe Name -getName (Elaboratable_Name _ n) = Just n -getName (Elaboratable_Apply _ f _) = getName f -getName (Elaboratable_Named_Apply _ f _ _) = getName f -getName (Elaboratable_Automatic_Apply _ f _) = getName f +getName (Elaborable_Name _ n) = Just n +getName (Elaborable_Apply _ f _) = getName f +getName (Elaborable_Named_Apply _ f _ _) = getName f +getName (Elaborable_Automatic_Apply _ f _) = getName f getName _ = Nothing export diff --git a/TTImp/Elab/App.idr b/TTImp/Elab/App.idr index 815f92e678..cbc703e451 100644 --- a/TTImp/Elab/App.idr +++ b/TTImp/Elab/App.idr @@ -298,21 +298,21 @@ mutual (knownRet : Bool) -> RawImp -> Core Bool needsDelayExpr False _ = pure False - needsDelayExpr True (Elaboratable_Name fc n) + needsDelayExpr True (Elaborable_Name fc n) = do defs <- get Ctxt pure $ case !(lookupCtxtName n (gamma defs)) of (_ :: _ :: _) => True _ => False - needsDelayExpr True (Elaboratable_Apply _ f _) = needsDelayExpr True f - needsDelayExpr True (Elaboratable_Automatic_Apply _ f _) = needsDelayExpr True f - needsDelayExpr True (Elaboratable_Named_Apply _ f _ _) = needsDelayExpr True f - needsDelayExpr True (Elaboratable_Lambda {}) = pure True - needsDelayExpr True (Elaboratable_Case {}) = pure True - needsDelayExpr True (Elaboratable_Local_Definitions {}) = pure True - needsDelayExpr True (Elaboratable_Record_Update {}) = pure True - needsDelayExpr True (Elaboratable_Alternative {}) = pure True - needsDelayExpr True (Elaboratable_Search {}) = pure True - needsDelayExpr True (Elaboratable_Rewrite {}) = pure True + needsDelayExpr True (Elaborable_Apply _ f _) = needsDelayExpr True f + needsDelayExpr True (Elaborable_Automatic_Apply _ f _) = needsDelayExpr True f + needsDelayExpr True (Elaborable_Named_Apply _ f _ _) = needsDelayExpr True f + needsDelayExpr True (Elaborable_Lambda {}) = pure True + needsDelayExpr True (Elaborable_Case {}) = pure True + needsDelayExpr True (Elaborable_Local_Definitions {}) = pure True + needsDelayExpr True (Elaborable_Record_Update {}) = pure True + needsDelayExpr True (Elaborable_Alternative {}) = pure True + needsDelayExpr True (Elaborable_Search {}) = pure True + needsDelayExpr True (Elaborable_Rewrite {}) = pure True needsDelayExpr True _ = pure False -- On the LHS, for any concrete thing, we need to make sure we know @@ -320,16 +320,16 @@ mutual -- out to be polymorphic needsDelayLHS : {auto c : Ref Ctxt Defs} -> RawImp -> Core Bool - needsDelayLHS (Elaboratable_Name fc n) = pure True - needsDelayLHS (Elaboratable_Apply _ f _) = needsDelayLHS f - needsDelayLHS (Elaboratable_Automatic_Apply _ f _) = needsDelayLHS f - needsDelayLHS (Elaboratable_Named_Apply _ f _ _) = needsDelayLHS f - needsDelayLHS (Elaboratable_Alternative {}) = pure True - needsDelayLHS (Elaboratable_As_Pattern _ _ _ _ t) = needsDelayLHS t - needsDelayLHS (Elaboratable_Search {}) = pure True - needsDelayLHS (Elaboratable_Primitive_Value {}) = pure True - needsDelayLHS (Elaboratable_Type_Universe _) = pure True - needsDelayLHS (Elaboratable_With_Unambiguous_Names _ _ t) = needsDelayLHS t + needsDelayLHS (Elaborable_Name fc n) = pure True + needsDelayLHS (Elaborable_Apply _ f _) = needsDelayLHS f + needsDelayLHS (Elaborable_Automatic_Apply _ f _) = needsDelayLHS f + needsDelayLHS (Elaborable_Named_Apply _ f _ _) = needsDelayLHS f + needsDelayLHS (Elaborable_Alternative {}) = pure True + needsDelayLHS (Elaborable_As_Pattern _ _ _ _ t) = needsDelayLHS t + needsDelayLHS (Elaborable_Search {}) = pure True + needsDelayLHS (Elaborable_Primitive_Value {}) = pure True + needsDelayLHS (Elaborable_Type_Universe _) = pure True + needsDelayLHS (Elaborable_With_Unambiguous_Names _ _ t) = needsDelayLHS t needsDelayLHS _ = pure False needsDelay : {auto c : Ref Ctxt Defs} -> @@ -399,13 +399,13 @@ mutual dotTerm : RawImp -> RawImp dotTerm tm = case tm of - Elaboratable_Must_Unify {} => tm - Elaboratable_Bind_Name {} => tm + Elaborable_Must_Unify {} => tm + Elaborable_Bind_Name {} => tm Implicit {} => tm - Elaboratable_As_Pattern _ _ _ _ (Elaboratable_Bind_Name {}) => tm - Elaboratable_As_Pattern _ _ _ _ (Implicit {}) => tm - Elaboratable_As_Pattern fc nameFC p t arg => Elaboratable_As_Pattern fc nameFC p t (Elaboratable_Must_Unify fc ErasedArg tm) - _ => Elaboratable_Must_Unify (getFC tm) ErasedArg tm + Elaborable_As_Pattern _ _ _ _ (Elaborable_Bind_Name {}) => tm + Elaborable_As_Pattern _ _ _ _ (Implicit {}) => tm + Elaborable_As_Pattern fc nameFC p t arg => Elaborable_As_Pattern fc nameFC p t (Elaborable_Must_Unify fc ErasedArg tm) + _ => Elaborable_Must_Unify (getFC tm) ErasedArg tm dotErased _ _ _ _ _ tm = pure tm -- Check the rest of an application given the argument type and the @@ -569,7 +569,7 @@ mutual findBindAllExpPattern = lookup (UN Underscore) isImplicitAs : RawImp -> Bool - isImplicitAs (Elaboratable_As_Pattern _ _ UseLeft _ (Implicit {})) = True + isImplicitAs (Elaborable_As_Pattern _ _ UseLeft _ (Implicit {})) = True isImplicitAs _ = False isBindAllExpPattern : Name -> Bool @@ -808,13 +808,13 @@ checkApp : {vars : _} -> (namedargs : List (Name, RawImp)) -> Maybe (Glued vars) -> Core (Term vars, Glued vars) -checkApp rig elabinfo nest env fc (Elaboratable_Apply fc' fn arg) expargs autoargs namedargs exp +checkApp rig elabinfo nest env fc (Elaborable_Apply fc' fn arg) expargs autoargs namedargs exp = checkApp rig elabinfo nest env fc' fn (arg :: expargs) autoargs namedargs exp -checkApp rig elabinfo nest env fc (Elaboratable_Automatic_Apply fc' fn arg) expargs autoargs namedargs exp +checkApp rig elabinfo nest env fc (Elaborable_Automatic_Apply fc' fn arg) expargs autoargs namedargs exp = checkApp rig elabinfo nest env fc' fn expargs (arg :: autoargs) namedargs exp -checkApp rig elabinfo nest env fc (Elaboratable_Named_Apply fc' fn nm arg) expargs autoargs namedargs exp +checkApp rig elabinfo nest env fc (Elaborable_Named_Apply fc' fn nm arg) expargs autoargs namedargs exp = checkApp rig elabinfo nest env fc' fn expargs autoargs ((nm, arg) :: namedargs) exp -checkApp rig elabinfo nest env fc (Elaboratable_Name fc' n) expargs autoargs namedargs exp +checkApp rig elabinfo nest env fc (Elaborable_Name fc' n) expargs autoargs namedargs exp = do (ntm, arglen, nty_in) <- getVarType elabinfo.elabMode rig nest env fc' n nty <- getNF nty_in prims <- getPrimitiveNames @@ -869,7 +869,7 @@ checkApp rig elabinfo nest env fc (Elaboratable_Name fc' n) expargs autoargs nam -- If it's a primitive function applied to a constant on the LHS, treat it -- as an expression because we'll normalise the function away and match on -- the result - updateElabInfo prims (InLHS _) n [Elaboratable_Primitive_Value fc c] elabinfo = + updateElabInfo prims (InLHS _) n [Elaborable_Primitive_Value fc c] elabinfo = do if isPrimName prims !(getFullName n) then pure ({ elabMode := InExpr } elabinfo) else pure elabinfo diff --git a/TTImp/Elab/Binders.idr b/TTImp/Elab/Binders.idr index b8ef5a1c1e..1f594c6a45 100644 --- a/TTImp/Elab/Binders.idr +++ b/TTImp/Elab/Binders.idr @@ -192,7 +192,7 @@ checkLambda rig_in elabinfo nest env fc rigl info n argTy scope (Just expty_in) logTermNF "elab.binder" 10 "Lambda type" env exptynf logGlueNF "elab.binder" 10 "Got scope type" env' scopet - -- Currently, the fc a PLam holds (and that Elaboratable_Lambda gets as a consequence) + -- Currently, the fc a PLam holds (and that Elaborable_Lambda gets as a consequence) -- is the file context of the argument to the lambda. This fits nicely -- in this exact use, but is likely a bug. log "metadata.names" 7 "checkLambda is adding ↓" diff --git a/TTImp/Elab/Case.idr b/TTImp/Elab/Case.idr index 1e49e3b58f..316672c822 100644 --- a/TTImp/Elab/Case.idr +++ b/TTImp/Elab/Case.idr @@ -104,10 +104,10 @@ extendNeeded b env needed findScrutinee : {vs : _} -> Env Term vs -> RawImp -> Maybe (Var vs) -findScrutinee {vs = n' :: _} (b :: bs) (Elaboratable_Name loc' n) +findScrutinee {vs = n' :: _} (b :: bs) (Elaborable_Name loc' n) = if n' == n && not (isLet b) then Just first - else do MkVar p <- findScrutinee bs (Elaboratable_Name loc' n) + else do MkVar p <- findScrutinee bs (Elaborable_Name loc' n) Just (MkVar (Later p)) findScrutinee _ _ = Nothing @@ -120,7 +120,7 @@ bindCaseLocals : FC -> List (Name, Maybe Name, List (Var vars)) -> bindCaseLocals fc [] args rhs = rhs bindCaseLocals fc ((n, mn, envns) :: rest) argns rhs = -- trace ("Case local " ++ show (n,mn,envns) ++ " from " ++ show argns) $ - Elaboratable_Case_Local_Definition fc n (fromMaybe n mn) + Elaborable_Case_Local_Definition fc n (fromMaybe n mn) (map getNameFrom envns) (bindCaseLocals fc rest argns rhs) where @@ -241,7 +241,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp logTermNF "elab.case" 2 "Case application" env appTm -- Start with empty nested names, since we've extended the rhs with - -- Elaboratable_Case_Local_Definition so they'll get rebuilt with the right environment + -- Elaborable_Case_Local_Definition so they'll get rebuilt with the right environment let nest' = MkNested [] ust <- get UST -- We don't want to keep rechecking delayed elaborators in the @@ -249,7 +249,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp -- we come out again, so save them let olddelayed = delayedElab ust put UST ({ delayedElab := [] } ust) - processDecl [InCase] nest' Env.empty (Elaboratable_Definition fc casen alts') + processDecl [InCase] nest' Env.empty (Elaborable_Definition fc casen alts') -- If there's no duplication of the scrutinee in the block, -- flag it as inlinable. @@ -275,7 +275,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp b' :: mkLocalEnv bs -- Return the original name in the environment, and what it needs to be - -- called in the case block. We need to mapping to build the Elaboratable_Case_Local_Definition + -- called in the case block. We need to mapping to build the Elaborable_Case_Local_Definition -- so that it applies to the right original variable getBindName : Int -> Name -> List Name -> (Name, Name) getBindName idx n@(UN un) vs @@ -293,7 +293,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp = let n = getBindName idx v used (ns, rest) = addEnv (idx + 1) bs (snd n :: used) ns' = n :: ns in - (ns', Elaboratable_As_Pattern fc EmptyFC UseLeft (snd n) (Implicit fc True) :: rest) + (ns', Elaborable_As_Pattern fc EmptyFC UseLeft (snd n) (Implicit fc True) :: rest) -- Replace a variable in the argument list; if the reference is to -- a variable kept in the outer environment (therefore not an argument @@ -301,7 +301,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp replace : (idx : Nat) -> RawImp -> List RawImp -> List RawImp replace Z lhs (old :: xs) = let lhs' = case old of - Elaboratable_As_Pattern loc' nameLoc' side n _ => Elaboratable_As_Pattern loc' nameLoc' side n lhs + Elaborable_As_Pattern loc' nameLoc' side n _ => Elaborable_As_Pattern loc' nameLoc' side n lhs _ => lhs in lhs' :: xs replace (S k) lhs (x :: xs) @@ -318,17 +318,17 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp -- Names used in the pattern we're matching on, so don't bind them -- in the generated case block usedIn : RawImp -> List Name - usedIn (Elaboratable_Bind_Name _ n) = [n] - usedIn (Elaboratable_Apply _ f a) = usedIn f ++ usedIn a - usedIn (Elaboratable_As_Pattern _ _ _ n a) = n :: usedIn a - usedIn (Elaboratable_Alternative _ _ alts) = concatMap usedIn alts + usedIn (Elaborable_Bind_Name _ n) = [n] + usedIn (Elaborable_Apply _ f a) = usedIn f ++ usedIn a + usedIn (Elaborable_As_Pattern _ _ _ n a) = n :: usedIn a + usedIn (Elaborable_Alternative _ _ alts) = concatMap usedIn alts usedIn _ = [] -- Get a name update for the LHS (so that if there's a nested data declaration -- the constructors are applied to the environment in the case block) nestLHS : FC -> (Name, (Maybe Name, List (Var vars), a)) -> (Name, RawImp) nestLHS fc (n, (mn, ns, t)) - = (n, apply (Elaboratable_Name fc (fromMaybe n mn)) + = (n, apply (Elaborable_Name fc (fromMaybe n mn)) (map (const (Implicit fc False)) ns)) applyNested : NestedNames vars -> RawImp -> RawImp @@ -342,7 +342,7 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp updateClause casen splitOn nest env (PatClause loc' lhs rhs) = let (ns, args) = addEnv 0 env (usedIn lhs) args' = mkSplit splitOn lhs args - lhs' = apply (Elaboratable_Name loc' casen) args' in + lhs' = apply (Elaborable_Name loc' casen) args' in PatClause loc' (applyNested nest lhs') (bindCaseLocals loc' (map getNestData (names nest)) ns rhs) @@ -350,12 +350,12 @@ caseBlock {vars} rigc elabinfo fc nest env opts scr scrtm scrty caseRig alts exp updateClause casen splitOn nest env (WithClause loc' lhs rig wval prf flags cs) = let (_, args) = addEnv 0 env (usedIn lhs) args' = mkSplit splitOn lhs args - lhs' = apply (Elaboratable_Name loc' casen) args' in + lhs' = apply (Elaborable_Name loc' casen) args' in WithClause loc' (applyNested nest lhs') rig wval prf flags cs updateClause casen splitOn nest env (ImpossibleClause loc' lhs) = let (_, args) = addEnv 0 env (usedIn lhs) args' = mkSplit splitOn lhs args - lhs' = apply (Elaboratable_Name loc' casen) args' in + lhs' = apply (Elaborable_Name loc' casen) args' in ImpossibleClause loc' (applyNested nest lhs') @@ -416,10 +416,10 @@ checkCase rig elabinfo nest env fc opts scr scrty_in alts exp applyTo : Defs -> RawImp -> ClosedNF -> Core RawImp applyTo defs ty (NBind fc _ (Pi _ _ Explicit _) sc) - = applyTo defs (Elaboratable_Apply fc ty (Implicit fc False)) + = applyTo defs (Elaborable_Apply fc ty (Implicit fc False)) !(sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder))) applyTo defs ty (NBind _ x (Pi {}) sc) - = applyTo defs (Elaboratable_Named_Apply fc ty x (Implicit fc False)) + = applyTo defs (Elaborable_Named_Apply fc ty x (Implicit fc False)) !(sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder))) applyTo defs ty _ = pure ty @@ -439,12 +439,12 @@ checkCase rig elabinfo nest env fc opts scr scrty_in alts exp guessScrType [] = pure $ Implicit fc False guessScrType (PatClause _ x _ :: xs) = case getFn x of - Elaboratable_Name _ n => + Elaborable_Name _ n => do defs <- get Ctxt [(_, (_, ty))] <- lookupTyName (mapNestedName nest n) (gamma defs) | _ => guessScrType xs Just (tyn, tyty) <- getRetTy defs !(nf defs Env.empty ty) | _ => guessScrType xs - applyTo defs (Elaboratable_Name fc tyn) tyty + applyTo defs (Elaborable_Name fc tyn) tyty _ => guessScrType xs guessScrType (_ :: xs) = guessScrType xs diff --git a/TTImp/Elab/ImplicitBind.idr b/TTImp/Elab/ImplicitBind.idr index 0635f44a6a..9c7ce32076 100644 --- a/TTImp/Elab/ImplicitBind.idr +++ b/TTImp/Elab/ImplicitBind.idr @@ -428,7 +428,7 @@ checkBindVar rig elabinfo nest env fc nm topexp let False = case implicitMode elabinfo of PI _ => maybe False (const True) (defined nm env) _ => False - | _ => check rig elabinfo nest env (Elaboratable_Name fc nm) topexp + | _ => check rig elabinfo nest env (Elaborable_Name fc nm) topexp est <- get EST let n = PV nm (defining est) noteLHSPatVar elabmode nm diff --git a/TTImp/Elab/Local.idr b/TTImp/Elab/Local.idr index e1405abba1..9f812877fd 100644 --- a/TTImp/Elab/Local.idr +++ b/TTImp/Elab/Local.idr @@ -103,7 +103,7 @@ localHelper {vars} nest env nestdecls_in func updateDataName nest (MkImpLater loc' n tycons) = MkImpLater loc' (mapNestedName nest n) tycons - updateFieldName : NestedNames vars -> Elaboratable_Field -> Elaboratable_Field + updateFieldName : NestedNames vars -> Elaborable_Field -> Elaborable_Field updateFieldName nest field = update "name" (map (mapNestedName nest)) field @@ -119,34 +119,34 @@ localHelper {vars} nest env nestdecls_in func updateRecordNS nest (Just ns) = Just $ show $ mapNestedName nest (UN $ mkUserName ns) updateName : NestedNames vars -> ImpDecl -> ImpDecl - updateName nest (Elaboratable_Claim claim) - = Elaboratable_Claim $ map {type $= updateTyName nest} claim - updateName nest (Elaboratable_Definition loc' n cs) - = Elaboratable_Definition loc' (mapNestedName nest n) cs - updateName nest (Elaboratable_Data_Declaration loc' vis mbt d) - = Elaboratable_Data_Declaration loc' vis mbt (updateDataName nest d) - updateName nest (Elaboratable_Record_Declaration loc' ns vis mbt imprecord) - = Elaboratable_Record_Declaration loc' (updateRecordNS nest ns) vis mbt (map (updateRecordName nest) imprecord) + updateName nest (Elaborable_Claim claim) + = Elaborable_Claim $ map {type $= updateTyName nest} claim + updateName nest (Elaborable_Definition loc' n cs) + = Elaborable_Definition loc' (mapNestedName nest n) cs + updateName nest (Elaborable_Data_Declaration loc' vis mbt d) + = Elaborable_Data_Declaration loc' vis mbt (updateDataName nest d) + updateName nest (Elaborable_Record_Declaration loc' ns vis mbt imprecord) + = Elaborable_Record_Declaration loc' (updateRecordNS nest ns) vis mbt (map (updateRecordName nest) imprecord) updateName nest i = i setPublic : ImpDecl -> ImpDecl - setPublic (Elaboratable_Claim claim) - = Elaboratable_Claim $ map {vis := Public} claim - setPublic (Elaboratable_Data_Declaration fc _ mbt d) = Elaboratable_Data_Declaration fc (specified Public) mbt d - setPublic (Elaboratable_Record_Declaration fc c _ mbt r) = Elaboratable_Record_Declaration fc c (specified Public) mbt r - setPublic (Elaboratable_Parameter_Block fc ps decls) - = Elaboratable_Parameter_Block fc ps (map setPublic decls) - setPublic (Elaboratable_Namespace_Block fc ps decls) - = Elaboratable_Namespace_Block fc ps (map setPublic decls) + setPublic (Elaborable_Claim claim) + = Elaborable_Claim $ map {vis := Public} claim + setPublic (Elaborable_Data_Declaration fc _ mbt d) = Elaborable_Data_Declaration fc (specified Public) mbt d + setPublic (Elaborable_Record_Declaration fc c _ mbt r) = Elaborable_Record_Declaration fc c (specified Public) mbt r + setPublic (Elaborable_Parameter_Block fc ps decls) + = Elaborable_Parameter_Block fc ps (map setPublic decls) + setPublic (Elaborable_Namespace_Block fc ps decls) + = Elaborable_Namespace_Block fc ps (map setPublic decls) setPublic d = d setErased : ImpDecl -> ImpDecl - setErased (Elaboratable_Claim claim) - = Elaboratable_Claim $ map {rig := erased} claim - setErased (Elaboratable_Parameter_Block fc ps decls) - = Elaboratable_Parameter_Block fc ps (map setErased decls) - setErased (Elaboratable_Namespace_Block fc ps decls) - = Elaboratable_Namespace_Block fc ps (map setErased decls) + setErased (Elaborable_Claim claim) + = Elaborable_Claim $ map {rig := erased} claim + setErased (Elaborable_Parameter_Block fc ps decls) + = Elaborable_Parameter_Block fc ps (map setErased decls) + setErased (Elaborable_Namespace_Block fc ps decls) + = Elaborable_Namespace_Block fc ps (map setErased decls) setErased d = d export diff --git a/TTImp/Elab/Quote.idr b/TTImp/Elab/Quote.idr index 72b5397d03..5f692e638c 100644 --- a/TTImp/Elab/Quote.idr +++ b/TTImp/Elab/Quote.idr @@ -25,52 +25,52 @@ mutual {auto u : Ref UST UState} -> RawImp -> Core RawImp - getUnquote (Elaboratable_Dependent_Function_Type fc c p n arg ret) - = pure $ Elaboratable_Dependent_Function_Type fc c p n !(getUnquote arg) !(getUnquote ret) - getUnquote (Elaboratable_Lambda fc c p n arg sc) - = pure $ Elaboratable_Lambda fc c p n !(getUnquote arg) !(getUnquote sc) - getUnquote (Elaboratable_Binding fc lhsFC c n ty val sc) - = pure $ Elaboratable_Binding fc lhsFC c n !(getUnquote ty) !(getUnquote val) !(getUnquote sc) - getUnquote (Elaboratable_Case fc opts sc ty cs) - = pure $ Elaboratable_Case fc opts + getUnquote (Elaborable_Dependent_Function_Type fc c p n arg ret) + = pure $ Elaborable_Dependent_Function_Type fc c p n !(getUnquote arg) !(getUnquote ret) + getUnquote (Elaborable_Lambda fc c p n arg sc) + = pure $ Elaborable_Lambda fc c p n !(getUnquote arg) !(getUnquote sc) + getUnquote (Elaborable_Binding fc lhsFC c n ty val sc) + = pure $ Elaborable_Binding fc lhsFC c n !(getUnquote ty) !(getUnquote val) !(getUnquote sc) + getUnquote (Elaborable_Case fc opts sc ty cs) + = pure $ Elaborable_Case fc opts !(getUnquote sc) !(getUnquote ty) !(traverse getUnquoteClause cs) - getUnquote (Elaboratable_Local_Definitions fc ds sc) - = pure $ Elaboratable_Local_Definitions fc !(traverse getUnquoteDecl ds) !(getUnquote sc) - getUnquote (Elaboratable_Record_Update fc ds sc) - = pure $ Elaboratable_Record_Update fc !(traverse getUnquoteUpdate ds) !(getUnquote sc) - getUnquote (Elaboratable_Apply fc f a) - = pure $ Elaboratable_Apply fc !(getUnquote f) !(getUnquote a) - getUnquote (Elaboratable_Automatic_Apply fc f a) - = pure $ Elaboratable_Automatic_Apply fc !(getUnquote f) !(getUnquote a) - getUnquote (Elaboratable_Named_Apply fc f n a) - = pure $ Elaboratable_Named_Apply fc !(getUnquote f) n !(getUnquote a) - getUnquote (Elaboratable_With_Apply fc f a) - = pure $ Elaboratable_With_Apply fc !(getUnquote f) !(getUnquote a) - getUnquote (Elaboratable_Alternative fc at as) - = pure $ Elaboratable_Alternative fc at !(traverse getUnquote as) - getUnquote (Elaboratable_Rewrite fc f a) - = pure $ Elaboratable_Rewrite fc !(getUnquote f) !(getUnquote a) - getUnquote (Elaboratable_Coerced fc t) - = pure $ Elaboratable_Coerced fc !(getUnquote t) - getUnquote (Elaboratable_Bind_Here fc m t) - = pure $ Elaboratable_Bind_Here fc m !(getUnquote t) - getUnquote (Elaboratable_As_Pattern fc nameFC u nm t) - = pure $ Elaboratable_As_Pattern fc nameFC u nm !(getUnquote t) - getUnquote (Elaboratable_Must_Unify fc r t) - = pure $ Elaboratable_Must_Unify fc r !(getUnquote t) - getUnquote (Elaboratable_Delayed_Type fc r t) - = pure $ Elaboratable_Delayed_Type fc r !(getUnquote t) - getUnquote (Elaboratable_Delay fc t) - = pure $ Elaboratable_Delay fc !(getUnquote t) - getUnquote (Elaboratable_Force fc t) - = pure $ Elaboratable_Force fc !(getUnquote t) - getUnquote (Elaboratable_Quote fc t) - = pure $ Elaboratable_Quote fc !(getUnquote t) - getUnquote (Elaboratable_Unquote fc tm) + getUnquote (Elaborable_Local_Definitions fc ds sc) + = pure $ Elaborable_Local_Definitions fc !(traverse getUnquoteDecl ds) !(getUnquote sc) + getUnquote (Elaborable_Record_Update fc ds sc) + = pure $ Elaborable_Record_Update fc !(traverse getUnquoteUpdate ds) !(getUnquote sc) + getUnquote (Elaborable_Apply fc f a) + = pure $ Elaborable_Apply fc !(getUnquote f) !(getUnquote a) + getUnquote (Elaborable_Automatic_Apply fc f a) + = pure $ Elaborable_Automatic_Apply fc !(getUnquote f) !(getUnquote a) + getUnquote (Elaborable_Named_Apply fc f n a) + = pure $ Elaborable_Named_Apply fc !(getUnquote f) n !(getUnquote a) + getUnquote (Elaborable_With_Apply fc f a) + = pure $ Elaborable_With_Apply fc !(getUnquote f) !(getUnquote a) + getUnquote (Elaborable_Alternative fc at as) + = pure $ Elaborable_Alternative fc at !(traverse getUnquote as) + getUnquote (Elaborable_Rewrite fc f a) + = pure $ Elaborable_Rewrite fc !(getUnquote f) !(getUnquote a) + getUnquote (Elaborable_Coerced fc t) + = pure $ Elaborable_Coerced fc !(getUnquote t) + getUnquote (Elaborable_Bind_Here fc m t) + = pure $ Elaborable_Bind_Here fc m !(getUnquote t) + getUnquote (Elaborable_As_Pattern fc nameFC u nm t) + = pure $ Elaborable_As_Pattern fc nameFC u nm !(getUnquote t) + getUnquote (Elaborable_Must_Unify fc r t) + = pure $ Elaborable_Must_Unify fc r !(getUnquote t) + getUnquote (Elaborable_Delayed_Type fc r t) + = pure $ Elaborable_Delayed_Type fc r !(getUnquote t) + getUnquote (Elaborable_Delay fc t) + = pure $ Elaborable_Delay fc !(getUnquote t) + getUnquote (Elaborable_Force fc t) + = pure $ Elaborable_Force fc !(getUnquote t) + getUnquote (Elaborable_Quote fc t) + = pure $ Elaborable_Quote fc !(getUnquote t) + getUnquote (Elaborable_Unquote fc tm) = do qv <- genVarName "q" update Unq ((qv, fc, tm) ::) - pure (Elaboratable_Unquote fc (Elaboratable_Name fc qv)) -- turned into just qv when reflecting + pure (Elaborable_Unquote fc (Elaborable_Name fc qv)) -- turned into just qv when reflecting getUnquote tm = pure tm getUnquoteClause : {auto c : Ref Ctxt Defs} -> @@ -95,10 +95,10 @@ mutual getUnquoteUpdate : {auto c : Ref Ctxt Defs} -> {auto q : Ref Unq (List (Name, FC, RawImp))} -> {auto u : Ref UST UState} -> - Elaboratable_Field_Update -> - Core Elaboratable_Field_Update - getUnquoteUpdate (Elaboratable_Set_Field p t) = pure $ Elaboratable_Set_Field p !(getUnquote t) - getUnquoteUpdate (Elaboratable_Apply_To_Field p t) = pure $ Elaboratable_Apply_To_Field p !(getUnquote t) + Elaborable_Field_Update -> + Core Elaborable_Field_Update + getUnquoteUpdate (Elaborable_Set_Field p t) = pure $ Elaborable_Set_Field p !(getUnquote t) + getUnquoteUpdate (Elaborable_Apply_To_Field p t) = pure $ Elaborable_Apply_To_Field p !(getUnquote t) getUnquoteRecord : {auto c : Ref Ctxt Defs} -> {auto q : Ref Unq (List (Name, FC, RawImp))} -> @@ -126,22 +126,22 @@ mutual {auto u : Ref UST UState} -> ImpDecl -> Core ImpDecl - getUnquoteDecl (Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data c v opts ty))) - = pure $ Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data c v opts !(traverse getUnquote ty))) - getUnquoteDecl (Elaboratable_Data_Declaration fc v mbt d) - = pure $ Elaboratable_Data_Declaration fc v mbt !(getUnquoteData d) - getUnquoteDecl (Elaboratable_Definition fc v d) - = pure $ Elaboratable_Definition fc v !(traverse getUnquoteClause d) - getUnquoteDecl (Elaboratable_Parameter_Block fc ps ds) - = pure $ Elaboratable_Parameter_Block fc -- We also unquote default arguments here too + getUnquoteDecl (Elaborable_Claim (MkWithData fc (Make_Elaborable_Claim_Data c v opts ty))) + = pure $ Elaborable_Claim (MkWithData fc (Make_Elaborable_Claim_Data c v opts !(traverse getUnquote ty))) + getUnquoteDecl (Elaborable_Data_Declaration fc v mbt d) + = pure $ Elaborable_Data_Declaration fc v mbt !(getUnquoteData d) + getUnquoteDecl (Elaborable_Definition fc v d) + = pure $ Elaborable_Definition fc v !(traverse getUnquoteClause d) + getUnquoteDecl (Elaborable_Parameter_Block fc ps ds) + = pure $ Elaborable_Parameter_Block fc -- We also unquote default arguments here too !(traverseList1 (traverse (traverse getUnquote)) ps) !(traverse getUnquoteDecl ds) - getUnquoteDecl (Elaboratable_Record_Declaration fc ns v mbt d) - = pure $ Elaboratable_Record_Declaration fc ns v mbt !(traverse getUnquoteRecord d) - getUnquoteDecl (Elaboratable_Namespace_Block fc ns ds) - = pure $ Elaboratable_Namespace_Block fc ns !(traverse getUnquoteDecl ds) - getUnquoteDecl (Elaboratable_Transformation fc n l r) - = pure $ Elaboratable_Transformation fc n !(getUnquote l) !(getUnquote r) + getUnquoteDecl (Elaborable_Record_Declaration fc ns v mbt d) + = pure $ Elaborable_Record_Declaration fc ns v mbt !(traverse getUnquoteRecord d) + getUnquoteDecl (Elaborable_Namespace_Block fc ns ds) + = pure $ Elaborable_Namespace_Block fc ns !(traverse getUnquoteDecl ds) + getUnquoteDecl (Elaborable_Transformation fc n l r) + = pure $ Elaborable_Transformation fc n !(getUnquote l) !(getUnquote r) getUnquoteDecl d = pure d bindUnqs : {vars : _} -> diff --git a/TTImp/Elab/Record.idr b/TTImp/Elab/Record.idr index 15da45deb1..cedcd71392 100644 --- a/TTImp/Elab/Record.idr +++ b/TTImp/Elab/Record.idr @@ -52,11 +52,11 @@ Show Rec where toLHS' : FC -> Rec -> (Maybe Name, RawImp) toLHS' loc (Field mn@(Just _) n _) - = (mn, Elaboratable_As_Pattern loc (virtualiseFC loc) UseRight (UN $ Basic n) (Implicit loc True)) -toLHS' loc (Field mn n _) = (mn, Elaboratable_Bind_Name (virtualiseFC loc) (UN $ Basic n)) + = (mn, Elaborable_As_Pattern loc (virtualiseFC loc) UseRight (UN $ Basic n) (Implicit loc True)) +toLHS' loc (Field mn n _) = (mn, Elaborable_Bind_Name (virtualiseFC loc) (UN $ Basic n)) toLHS' loc (Constr mn con args) = let args' = map (toLHS' loc . snd) args in - (mn, gapply (Elaboratable_Name loc con) args') + (mn, gapply (Elaborable_Name loc con) args') toLHS : FC -> Rec -> RawImp toLHS fc r = snd (toLHS' fc r) @@ -65,7 +65,7 @@ toRHS' : FC -> Rec -> (Maybe Name, RawImp) toRHS' loc (Field mn _ val) = (mn, val) toRHS' loc (Constr mn con args) = let args' = map (toRHS' loc . snd) args in - (mn, gapply (Elaboratable_Name loc con) args') + (mn, gapply (Elaborable_Name loc con) args') toRHS : FC -> Rec -> RawImp toRHS fc r = snd (toRHS' fc r) @@ -145,7 +145,7 @@ findPath loc (p :: ps) full (Just tyn) val (Field mn n v) -- If other types depend on that implicit argument, leave it as _ by default let arg = case (flip contains tyArgs) <$> imp of Just True => Implicit loc False - _ => Elaboratable_Name (virtualiseFC loc) (UN $ Basic fldn) + _ => Elaborable_Name (virtualiseFC loc) (UN $ Basic fldn) pure ((p, Field imp fldn arg) :: args') findPath loc (p :: ps) full tyn val (Constr mn con args) @@ -161,19 +161,19 @@ findPath loc (p :: ps) full tyn val (Constr mn con args) getSides : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> Elaboratable_Field_Update -> Name -> RawImp -> Rec -> + FC -> Elaborable_Field_Update -> Name -> RawImp -> Rec -> Core Rec -getSides loc (Elaboratable_Set_Field path val) tyn orig rec +getSides loc (Elaborable_Set_Field path val) tyn orig rec -- update 'rec' so that 'path' is accessible on the lhs and rhs, -- then set the path on the rhs to 'val' = findPath loc path path (Just tyn) (const val) rec -getSides loc (Elaboratable_Apply_To_Field path val) tyn orig rec +getSides loc (Elaborable_Apply_To_Field path val) tyn orig rec = findPath loc path path (Just tyn) - (\n => apply val [Elaboratable_Name (virtualiseFC loc) (UN $ Basic n)]) rec + (\n => apply val [Elaborable_Name (virtualiseFC loc) (UN $ Basic n)]) rec getAllSides : {auto c : Ref Ctxt Defs} -> {auto u : Ref UST UState} -> - FC -> List Elaboratable_Field_Update -> Name -> + FC -> List Elaborable_Field_Update -> Name -> RawImp -> Rec -> Core Rec getAllSides loc [] tyn orig rec = pure rec @@ -181,7 +181,7 @@ getAllSides loc (u :: upds) tyn orig rec = getAllSides loc upds tyn orig !(getSides loc u tyn orig rec) checkForDuplicates : - List Elaboratable_Field_Update -> + List Elaborable_Field_Update -> (seen, dups : SortedSet (List String)) -> SortedSet (List String) checkForDuplicates [] seen dups = dups @@ -198,7 +198,7 @@ recUpdate : {vars : _} -> {auto u : Ref UST UState} -> RigCount -> ElabInfo -> FC -> NestedNames vars -> Env Term vars -> - List Elaboratable_Field_Update -> + List Elaborable_Field_Update -> (rec : RawImp) -> (grecty : Glued vars) -> Core RawImp recUpdate rigc elabinfo iloc nest env flds rec grecty @@ -211,8 +211,8 @@ recUpdate rigc elabinfo iloc nest env flds rec grecty | Nothing => throw (RecordTypeNeeded iloc env) fldn <- genFieldName "__fld" sides <- getAllSides iloc flds rectyn rec - (Field Nothing fldn (Elaboratable_Name vloc (UN $ Basic fldn))) - pure $ Elaboratable_Case vloc [] rec (Implicit vloc False) [mkClause sides] + (Field Nothing fldn (Elaborable_Name vloc (UN $ Basic fldn))) + pure $ Elaborable_Case vloc [] rec (Implicit vloc False) [mkClause sides] where vloc : FC vloc = virtualiseFC iloc @@ -239,7 +239,7 @@ checkUpdate : {vars : _} -> {auto o : Ref ROpts REPLOpts} -> RigCount -> ElabInfo -> NestedNames vars -> Env Term vars -> - FC -> List Elaboratable_Field_Update -> RawImp -> Maybe (Glued vars) -> + FC -> List Elaborable_Field_Update -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) checkUpdate rig elabinfo nest env fc upds rec expected = do recty <- case expected of diff --git a/TTImp/Elab/Rewrite.idr b/TTImp/Elab/Rewrite.idr index 1c283a462a..1188aae843 100644 --- a/TTImp/Elab/Rewrite.idr +++ b/TTImp/Elab/Rewrite.idr @@ -144,9 +144,9 @@ checkRewrite {vars} rigc elabinfo nest env ifc rule tm (Just expected) inScope {e=e'} vfc env' $ \e'' => let offset = mkSizeOf [rname, pname] in check {e = e''} rigc elabinfo (weakenNs offset nest) env' - (apply (Elaboratable_Name vfc lemma.name) - [ Elaboratable_Name vfc pname - , Elaboratable_Name vfc rname + (apply (Elaborable_Name vfc lemma.name) + [ Elaborable_Name vfc pname + , Elaborable_Name vfc rname , tm ]) (Just (gnf env' (weakenNs offset expTy))) rwty <- getTerm grwty diff --git a/TTImp/Elab/Term.idr b/TTImp/Elab/Term.idr index 87db168181..96a8207ee8 100644 --- a/TTImp/Elab/Term.idr +++ b/TTImp/Elab/Term.idr @@ -42,27 +42,27 @@ insertImpLam {vars} env tm (Just ty) = bindLam tm ty -- If we can decide whether we need implicit lambdas without looking -- at the normal form, do so bindLamTm : RawImp -> Term vs -> Core (Maybe RawImp) - bindLamTm tm@(Elaboratable_Lambda _ _ Implicit _ _ _) (Bind fc n (Pi _ _ Implicit _) sc) + bindLamTm tm@(Elaborable_Lambda _ _ Implicit _ _ _) (Bind fc n (Pi _ _ Implicit _) sc) = pure (Just tm) - bindLamTm tm@(Elaboratable_Lambda _ _ AutoImplicit _ _ _) (Bind fc n (Pi _ _ AutoImplicit _) sc) + bindLamTm tm@(Elaborable_Lambda _ _ AutoImplicit _ _ _) (Bind fc n (Pi _ _ AutoImplicit _) sc) = pure (Just tm) - bindLamTm tm@(Elaboratable_Lambda _ _ (DefImplicit _) _ _ _) (Bind fc n (Pi _ _ (DefImplicit _) _) sc) + bindLamTm tm@(Elaborable_Lambda _ _ (DefImplicit _) _ _ _) (Bind fc n (Pi _ _ (DefImplicit _) _) sc) = pure (Just tm) bindLamTm tm (Bind fc n (Pi _ c Implicit ty) sc) = do n' <- genVarName (nameRoot n) Just sc' <- bindLamTm tm sc | Nothing => pure Nothing - pure $ Just (Elaboratable_Lambda fc c Implicit (Just n') (Implicit fc False) sc') + pure $ Just (Elaborable_Lambda fc c Implicit (Just n') (Implicit fc False) sc') bindLamTm tm (Bind fc n (Pi _ c AutoImplicit ty) sc) = do n' <- genVarName (nameRoot n) Just sc' <- bindLamTm tm sc | Nothing => pure Nothing - pure $ Just (Elaboratable_Lambda fc c AutoImplicit (Just n') (Implicit fc False) sc') + pure $ Just (Elaborable_Lambda fc c AutoImplicit (Just n') (Implicit fc False) sc') bindLamTm tm (Bind fc n (Pi _ c (DefImplicit _) ty) sc) = do n' <- genVarName (nameRoot n) Just sc' <- bindLamTm tm sc | Nothing => pure Nothing - pure $ Just (Elaboratable_Lambda fc c (DefImplicit (Implicit fc False)) + pure $ Just (Elaborable_Lambda fc c (DefImplicit (Implicit fc False)) (Just n') (Implicit fc False) sc') bindLamTm tm exp = case getFn exp of @@ -72,28 +72,28 @@ insertImpLam {vars} env tm (Just ty) = bindLam tm ty _ => pure $ Just tm bindLamNF : RawImp -> NF vars -> Core RawImp - bindLamNF tm@(Elaboratable_Lambda _ _ Implicit _ _ _) (NBind fc n (Pi _ _ Implicit _) sc) + bindLamNF tm@(Elaborable_Lambda _ _ Implicit _ _ _) (NBind fc n (Pi _ _ Implicit _) sc) = pure tm - bindLamNF tm@(Elaboratable_Lambda _ _ AutoImplicit _ _ _) (NBind fc n (Pi _ _ AutoImplicit _) sc) + bindLamNF tm@(Elaborable_Lambda _ _ AutoImplicit _ _ _) (NBind fc n (Pi _ _ AutoImplicit _) sc) = pure tm bindLamNF tm (NBind fc n (Pi fc' c Implicit ty) sc) = do defs <- get Ctxt n' <- genVarName (nameRoot n) sctm <- sc defs (toClosure defaultOpts env (Ref fc Bound n')) sc' <- bindLamNF tm sctm - pure $ Elaboratable_Lambda fc c Implicit (Just n') (Implicit fc False) sc' + pure $ Elaborable_Lambda fc c Implicit (Just n') (Implicit fc False) sc' bindLamNF tm (NBind fc n (Pi fc' c AutoImplicit ty) sc) = do defs <- get Ctxt n' <- genVarName (nameRoot n) sctm <- sc defs (toClosure defaultOpts env (Ref fc Bound n')) sc' <- bindLamNF tm sctm - pure $ Elaboratable_Lambda fc c AutoImplicit (Just n') (Implicit fc False) sc' + pure $ Elaborable_Lambda fc c AutoImplicit (Just n') (Implicit fc False) sc' bindLamNF tm (NBind fc n (Pi _ c (DefImplicit _) ty) sc) = do defs <- get Ctxt n' <- genVarName (nameRoot n) sctm <- sc defs (toClosure defaultOpts env (Ref fc Bound n')) sc' <- bindLamNF tm sctm - pure $ Elaboratable_Lambda fc c (DefImplicit (Implicit fc False)) + pure $ Elaborable_Lambda fc c (DefImplicit (Implicit fc False)) (Just n') (Implicit fc False) sc' bindLamNF tm sc = pure tm @@ -119,52 +119,52 @@ checkTerm : {vars : _} -> RigCount -> ElabInfo -> NestedNames vars -> Env Term vars -> RawImp -> Maybe (Glued vars) -> Core (Term vars, Glued vars) -checkTerm rig elabinfo nest env (Elaboratable_Name fc n) exp +checkTerm rig elabinfo nest env (Elaborable_Name fc n) exp = -- It may actually turn out to be an application, if the expected -- type is expecting an implicit argument, so check it as an -- application with no arguments - checkApp rig elabinfo nest env fc (Elaboratable_Name fc n) [] [] [] exp -checkTerm rig elabinfo nest env (Elaboratable_Dependent_Function_Type fc r p Nothing argTy retTy) exp + checkApp rig elabinfo nest env fc (Elaborable_Name fc n) [] [] [] exp +checkTerm rig elabinfo nest env (Elaborable_Dependent_Function_Type fc r p Nothing argTy retTy) exp = do n <- case p of Explicit => genVarName "arg" Implicit => genVarName "impArg" AutoImplicit => genVarName "conArg" (DefImplicit _) => genVarName "defArg" checkPi rig elabinfo nest env fc r p n argTy retTy exp -checkTerm rig elabinfo nest env (Elaboratable_Dependent_Function_Type fc r p (Just (UN Underscore)) argTy retTy) exp - = checkTerm rig elabinfo nest env (Elaboratable_Dependent_Function_Type fc r p Nothing argTy retTy) exp -checkTerm rig elabinfo nest env (Elaboratable_Dependent_Function_Type fc r p (Just n) argTy retTy) exp +checkTerm rig elabinfo nest env (Elaborable_Dependent_Function_Type fc r p (Just (UN Underscore)) argTy retTy) exp + = checkTerm rig elabinfo nest env (Elaborable_Dependent_Function_Type fc r p Nothing argTy retTy) exp +checkTerm rig elabinfo nest env (Elaborable_Dependent_Function_Type fc r p (Just n) argTy retTy) exp = checkPi rig elabinfo nest env fc r p n argTy retTy exp -checkTerm rig elabinfo nest env (Elaboratable_Lambda fc r p (Just n) argTy scope) exp +checkTerm rig elabinfo nest env (Elaborable_Lambda fc r p (Just n) argTy scope) exp = checkLambda rig elabinfo nest env fc r p n argTy scope exp -checkTerm rig elabinfo nest env (Elaboratable_Lambda fc r p Nothing argTy scope) exp +checkTerm rig elabinfo nest env (Elaborable_Lambda fc r p Nothing argTy scope) exp = do n <- genVarName "_" checkLambda rig elabinfo nest env fc r p n argTy scope exp -checkTerm rig elabinfo nest env (Elaboratable_Binding fc lhsFC r n nTy nVal scope) exp +checkTerm rig elabinfo nest env (Elaborable_Binding fc lhsFC r n nTy nVal scope) exp = checkLet rig elabinfo nest env fc lhsFC r n nTy nVal scope exp -checkTerm rig elabinfo nest env (Elaboratable_Case fc opts scr scrty alts) exp +checkTerm rig elabinfo nest env (Elaborable_Case fc opts scr scrty alts) exp = checkCase rig elabinfo nest env fc opts scr scrty alts exp -checkTerm rig elabinfo nest env (Elaboratable_Local_Definitions fc nested scope) exp +checkTerm rig elabinfo nest env (Elaborable_Local_Definitions fc nested scope) exp = checkLocal rig elabinfo nest env fc nested scope exp -checkTerm rig elabinfo nest env (Elaboratable_Case_Local_Definition fc uname iname args scope) exp +checkTerm rig elabinfo nest env (Elaborable_Case_Local_Definition fc uname iname args scope) exp = checkCaseLocal rig elabinfo nest env fc uname iname args scope exp -checkTerm rig elabinfo nest env (Elaboratable_Record_Update fc upds rec) exp +checkTerm rig elabinfo nest env (Elaborable_Record_Update fc upds rec) exp = checkUpdate rig elabinfo nest env fc upds rec exp -checkTerm rig elabinfo nest env (Elaboratable_Apply fc fn arg) exp +checkTerm rig elabinfo nest env (Elaborable_Apply fc fn arg) exp = checkApp rig elabinfo nest env fc fn [arg] [] [] exp -checkTerm rig elabinfo nest env (Elaboratable_Automatic_Apply fc fn arg) exp +checkTerm rig elabinfo nest env (Elaborable_Automatic_Apply fc fn arg) exp = checkApp rig elabinfo nest env fc fn [] [arg] [] exp -checkTerm rig elabinfo nest env (Elaboratable_With_Apply fc fn arg) exp +checkTerm rig elabinfo nest env (Elaborable_With_Apply fc fn arg) exp = throw (GenericMsg fc "with application not implemented yet") -checkTerm rig elabinfo nest env (Elaboratable_Named_Apply fc fn nm arg) exp +checkTerm rig elabinfo nest env (Elaborable_Named_Apply fc fn nm arg) exp = checkApp rig elabinfo nest env fc fn [] [] [(nm, arg)] exp -checkTerm rig elabinfo nest env (Elaboratable_Search fc depth) (Just gexpty) +checkTerm rig elabinfo nest env (Elaborable_Search fc depth) (Just gexpty) = do est <- get EST nm <- genName "search" expty <- getTerm gexpty sval <- searchVar fc rig depth (Resolved (defining est)) env nest nm expty pure (sval, gexpty) -checkTerm rig elabinfo nest env (Elaboratable_Search fc depth) Nothing +checkTerm rig elabinfo nest env (Elaborable_Search fc depth) Nothing = do est <- get EST nmty <- genName "searchTy" u <- uniVar fc @@ -172,45 +172,45 @@ checkTerm rig elabinfo nest env (Elaboratable_Search fc depth) Nothing nm <- genName "search" sval <- searchVar fc rig depth (Resolved (defining est)) env nest nm ty pure (sval, gnf env ty) -checkTerm rig elabinfo nest env (Elaboratable_Alternative fc uniq alts) exp +checkTerm rig elabinfo nest env (Elaborable_Alternative fc uniq alts) exp = checkAlternative rig elabinfo nest env fc uniq alts exp -checkTerm rig elabinfo nest env (Elaboratable_Rewrite fc rule tm) exp +checkTerm rig elabinfo nest env (Elaborable_Rewrite fc rule tm) exp = checkRewrite rig elabinfo nest env fc rule tm exp -checkTerm rig elabinfo nest env (Elaboratable_Coerced fc tm) exp +checkTerm rig elabinfo nest env (Elaborable_Coerced fc tm) exp = checkTerm rig elabinfo nest env tm exp -checkTerm rig elabinfo nest env (Elaboratable_Bind_Here fc binder sc) exp +checkTerm rig elabinfo nest env (Elaborable_Bind_Here fc binder sc) exp = checkBindHere rig elabinfo nest env fc binder sc exp -checkTerm rig elabinfo nest env (Elaboratable_Bind_Name fc n) exp +checkTerm rig elabinfo nest env (Elaborable_Bind_Name fc n) exp = checkBindVar rig elabinfo nest env fc n exp -checkTerm rig elabinfo nest env (Elaboratable_As_Pattern fc nameFC side n_in tm) exp +checkTerm rig elabinfo nest env (Elaborable_As_Pattern fc nameFC side n_in tm) exp = checkAs rig elabinfo nest env fc nameFC side n_in tm exp -checkTerm rig elabinfo nest env (Elaboratable_Must_Unify fc reason tm) exp +checkTerm rig elabinfo nest env (Elaborable_Must_Unify fc reason tm) exp = checkDot rig elabinfo nest env fc reason tm exp -checkTerm rig elabinfo nest env (Elaboratable_Delayed_Type fc r tm) exp +checkTerm rig elabinfo nest env (Elaborable_Delayed_Type fc r tm) exp = checkDelayed rig elabinfo nest env fc r tm exp -checkTerm rig elabinfo nest env (Elaboratable_Delay fc tm) exp +checkTerm rig elabinfo nest env (Elaborable_Delay fc tm) exp = checkDelay rig elabinfo nest env fc tm exp -checkTerm rig elabinfo nest env (Elaboratable_Force fc tm) exp +checkTerm rig elabinfo nest env (Elaborable_Force fc tm) exp = checkForce rig elabinfo nest env fc tm exp -checkTerm rig elabinfo nest env (Elaboratable_Quote fc tm) exp +checkTerm rig elabinfo nest env (Elaborable_Quote fc tm) exp = checkQuote rig elabinfo nest env fc tm exp -checkTerm rig elabinfo nest env (Elaboratable_Quote_Name fc n) exp +checkTerm rig elabinfo nest env (Elaborable_Quote_Name fc n) exp = checkQuoteName rig elabinfo nest env fc n exp -checkTerm rig elabinfo nest env (Elaboratable_Quote_Declarations fc ds) exp +checkTerm rig elabinfo nest env (Elaborable_Quote_Declarations fc ds) exp = checkQuoteDecl rig elabinfo nest env fc ds exp -checkTerm rig elabinfo nest env (Elaboratable_Unquote fc tm) exp +checkTerm rig elabinfo nest env (Elaborable_Unquote fc tm) exp = throw (GenericMsg fc "Can't escape outside a quoted term") -checkTerm rig elabinfo nest env (Elaboratable_Run_Elaborator fc re tm) exp +checkTerm rig elabinfo nest env (Elaborable_Run_Elaborator fc re tm) exp = checkRunElab rig elabinfo nest env fc re tm exp -checkTerm {vars} rig elabinfo nest env (Elaboratable_Primitive_Value fc c) exp +checkTerm {vars} rig elabinfo nest env (Elaborable_Primitive_Value fc c) exp = do let (cval, cty) = checkPrim {vars} fc c checkExp rig elabinfo env fc cval (gnf env cty) exp -checkTerm rig elabinfo nest env (Elaboratable_Type_Universe fc) exp +checkTerm rig elabinfo nest env (Elaborable_Type_Universe fc) exp = do u <- uniVar fc checkExp rig elabinfo env fc (TType fc u) (gType fc u) exp -checkTerm rig elabinfo nest env (Elaboratable_Hole fc str) exp +checkTerm rig elabinfo nest env (Elaborable_Hole fc str) exp = checkHole rig elabinfo nest env fc (Basic str) exp -checkTerm rig elabinfo nest env (Elaboratable_Unification_Log fc lvl tm) exp +checkTerm rig elabinfo nest env (Elaborable_Unification_Log fc lvl tm) exp = withLogLevel lvl $ check rig elabinfo nest env tm exp checkTerm rig elabinfo nest env (Implicit fc b) (Just gexpty) = do nm <- genName "_" @@ -232,7 +232,7 @@ checkTerm rig elabinfo nest env (Implicit fc b) Nothing when (b && bindingVars elabinfo) $ update EST $ addBindIfUnsolved nm fc rig Explicit env metaval ty pure (metaval, gnf env ty) -checkTerm rig elabinfo nest env (Elaboratable_With_Unambiguous_Names fc ns rhs) exp +checkTerm rig elabinfo nest env (Elaborable_With_Unambiguous_Names fc ns rhs) exp = do -- enter the scope -> add unambiguous names est <- get EST rns <- resolveNames fc ns @@ -283,14 +283,14 @@ checkTerm rig elabinfo nest env (Elaboratable_With_Unambiguous_Names fc ns rhs) -- Core (Term vars, Glued vars) -- If we've just inserted an implicit coercion (in practice, that's either -- a force or delay) then check the term with any further insertions -TTImp.Elab.Check.check rigc elabinfo nest env (Elaboratable_Coerced fc tm) exp +TTImp.Elab.Check.check rigc elabinfo nest env (Elaborable_Coerced fc tm) exp = checkImp rigc elabinfo nest env tm exp -- Don't add implicits/coercions on local blocks or record updates -TTImp.Elab.Check.check rigc elabinfo nest env tm@(Elaboratable_Binding {}) exp +TTImp.Elab.Check.check rigc elabinfo nest env tm@(Elaborable_Binding {}) exp = checkImp rigc elabinfo nest env tm exp -TTImp.Elab.Check.check rigc elabinfo nest env tm@(Elaboratable_Local_Definitions {}) exp +TTImp.Elab.Check.check rigc elabinfo nest env tm@(Elaborable_Local_Definitions {}) exp = checkImp rigc elabinfo nest env tm exp -TTImp.Elab.Check.check rigc elabinfo nest env tm@(Elaboratable_Record_Update {}) exp +TTImp.Elab.Check.check rigc elabinfo nest env tm@(Elaborable_Record_Update {}) exp = checkImp rigc elabinfo nest env tm exp TTImp.Elab.Check.check rigc elabinfo nest env tm_in exp = do tm <- expandAmbigName (elabMode elabinfo) nest env tm_in [] tm_in exp diff --git a/TTImp/Impossible.idr b/TTImp/Impossible.idr index d508243eb4..e29c42c391 100644 --- a/TTImp/Impossible.idr +++ b/TTImp/Impossible.idr @@ -188,21 +188,21 @@ mutual (autoargs : List (WithFC RawImp)) -> (namedargs : List (Name, WithFC RawImp)) -> Core ClosedTerm - go (Elaboratable_Name fc n) exps autos named + go (Elaborable_Name fc n) exps autos named = buildApp fc n mty exps autos named - go (Elaboratable_As_Pattern fc fc' u n pat) exps autos named + go (Elaborable_As_Pattern fc fc' u n pat) exps autos named = go pat exps autos named - go (Elaboratable_Apply fc fn arg) exps autos named + go (Elaborable_Apply fc fn arg) exps autos named = go fn (MkFCVal fc arg :: exps) autos named - go (Elaboratable_With_Apply fc fn arg) exps autos named + go (Elaborable_With_Apply fc fn arg) exps autos named = go fn (MkFCVal fc arg :: exps) autos named - go (Elaboratable_Automatic_Apply fc fn arg) exps autos named + go (Elaborable_Automatic_Apply fc fn arg) exps autos named = go fn exps (MkFCVal fc arg :: autos) named - go (Elaboratable_Named_Apply fc fn nm arg) exps autos named + go (Elaborable_Named_Apply fc fn nm arg) exps autos named = go fn exps autos ((nm, MkFCVal fc arg) :: named) - go (Elaboratable_Must_Unify fc r tm) exps autos named + go (Elaborable_Must_Unify fc r tm) exps autos named = Erased fc . Dotted <$> go tm exps autos named - go (Elaboratable_Primitive_Value fc c) _ _ _ + go (Elaborable_Primitive_Value fc c) _ _ _ = do let tm = PrimVal fc c True <- isValidPrimType | _ => throw $ GenericMsg fc "\{show tm} does not match expected type" @@ -217,7 +217,7 @@ mutual (Nothing, NType {}) => pure True (Just t1, NPrimVal _ (PrT t2)) => pure (t1 == t2) _ => pure False - go (Elaboratable_Type_Universe fc) _ _ _ + go (Elaborable_Type_Universe fc) _ _ _ = do defs <- get Ctxt Just (NType {}) <- traverseOpt (evalClosure defs) mty | _ => throw $ GenericMsg fc "Type does not match expected type" @@ -225,10 +225,10 @@ mutual -- We're taking UniqueDefault here, _and_ we're falling through to error otherwise, which is sketchy. -- One option is to try each and emit an AmbiguousElab? We maybe should respect `UniqueDefault` if there -- is no evidence (mty), but we should _try_ to resolve here if there is an mty. - go (Elaboratable_Alternative _ (UniqueDefault tm) _) exps autos named + go (Elaborable_Alternative _ (UniqueDefault tm) _) exps autos named = go tm exps autos named go (Implicit fc _) _ _ _ = nextVar fc - go (Elaboratable_Bind_Name fc _) _ _ _ = nextVar fc + go (Elaborable_Bind_Name fc _) _ _ _ = nextVar fc go tm _ _ _ = do tm' <- pterm (map defaultKindedName tm) -- hack throw $ GenericMsg (getFC tm) "Unsupported term in impossible clause: \{show tm'}" @@ -254,18 +254,18 @@ getImpossibleTerm env nest tm else Implicit fc False :: addEnv fc env expandNest : RawImp -> RawImp - expandNest (Elaboratable_Name fc n) + expandNest (Elaborable_Name fc n) = case lookup n (names nest) of - Just (Just n', _, _) => Elaboratable_Name fc n' - _ => Elaboratable_Name fc n + Just (Just n', _, _) => Elaborable_Name fc n' + _ => Elaborable_Name fc n expandNest tm = tm -- Need to apply the function to the surrounding environment, and update -- the name to the proper one from the nested names map applyEnv : RawImp -> RawImp - applyEnv (Elaboratable_Apply fc fn arg) = Elaboratable_Apply fc (applyEnv fn) arg - applyEnv (Elaboratable_With_Apply fc fn arg) = Elaboratable_With_Apply fc (applyEnv fn) arg - applyEnv (Elaboratable_Automatic_Apply fc fn arg) = Elaboratable_Automatic_Apply fc (applyEnv fn) arg - applyEnv (Elaboratable_Named_Apply fc fn n arg) - = Elaboratable_Named_Apply fc (applyEnv fn) n arg + applyEnv (Elaborable_Apply fc fn arg) = Elaborable_Apply fc (applyEnv fn) arg + applyEnv (Elaborable_With_Apply fc fn arg) = Elaborable_With_Apply fc (applyEnv fn) arg + applyEnv (Elaborable_Automatic_Apply fc fn arg) = Elaborable_Automatic_Apply fc (applyEnv fn) arg + applyEnv (Elaborable_Named_Apply fc fn n arg) + = Elaborable_Named_Apply fc (applyEnv fn) n arg applyEnv tm = apply (expandNest tm) (addEnv (getFC tm) env) diff --git a/TTImp/Interactive/CaseSplit.idr b/TTImp/Interactive/CaseSplit.idr index 3feae3a945..d0a6536823 100644 --- a/TTImp/Interactive/CaseSplit.idr +++ b/TTImp/Interactive/CaseSplit.idr @@ -134,8 +134,8 @@ expandCon fc usedvars con = do defs <- get Ctxt Just ty <- lookupTyExact con (gamma defs) | Nothing => undefinedName fc con - pure (apply (Elaboratable_Name fc con) - (map (Elaboratable_Bind_Name fc . UN . Basic) + pure (apply (Elaborable_Name fc con) + (map (Elaborable_Bind_Name fc . UN . Basic) !(getArgNames defs [] usedvars Env.empty !(nf defs Env.empty ty)))) @@ -143,25 +143,25 @@ updateArg : {auto c : Ref Ctxt Defs} -> List Name -> -- all the variable names (var : Name) -> (con : Name) -> RawImp -> Core RawImp -updateArg allvars var con (Elaboratable_Name fc n) +updateArg allvars var con (Elaborable_Name fc n) = if n `elem` allvars then if n == var then expandCon fc (filter (/= n) allvars) con else pure $ Implicit fc True - else pure $ Elaboratable_Name fc n -updateArg allvars var con (Elaboratable_Apply fc f a) - = pure $ Elaboratable_Apply fc !(updateArg allvars var con f) + else pure $ Elaborable_Name fc n +updateArg allvars var con (Elaborable_Apply fc f a) + = pure $ Elaborable_Apply fc !(updateArg allvars var con f) !(updateArg allvars var con a) -updateArg allvars var con (Elaboratable_With_Apply fc f a) - = pure $ Elaboratable_With_Apply fc !(updateArg allvars var con f) +updateArg allvars var con (Elaborable_With_Apply fc f a) + = pure $ Elaborable_With_Apply fc !(updateArg allvars var con f) !(updateArg allvars var con a) -updateArg allvars var con (Elaboratable_Automatic_Apply fc f a) - = pure $ Elaboratable_Automatic_Apply fc !(updateArg allvars var con f) +updateArg allvars var con (Elaborable_Automatic_Apply fc f a) + = pure $ Elaborable_Automatic_Apply fc !(updateArg allvars var con f) !(updateArg allvars var con a) -updateArg allvars var con (Elaboratable_Named_Apply fc f n a) - = pure $ Elaboratable_Named_Apply fc !(updateArg allvars var con f) n +updateArg allvars var con (Elaborable_Named_Apply fc f n a) + = pure $ Elaborable_Named_Apply fc !(updateArg allvars var con f) n !(updateArg allvars var con a) -updateArg allvars var con (Elaboratable_As_Pattern fc nameFC s n p) +updateArg allvars var con (Elaborable_As_Pattern fc nameFC s n p) = updateArg allvars var con p updateArg allvars var con tm = pure $ Implicit (getFC tm) True @@ -204,37 +204,37 @@ recordUpdate : {auto u : Ref UPD Updates} -> FC -> Name -> RawImp -> Core () recordUpdate fc n tm = do u <- get UPD - let nupdates = mapSnd (Elaboratable_Name fc) <$> namemap u + let nupdates = mapSnd (Elaborable_Name fc) <$> namemap u put UPD ({ updates $= ((n, substNames [] nupdates tm) ::) } u) findUpdates : {auto u : Ref UPD Updates} -> Defs -> RawImp -> RawImp -> Core () -findUpdates defs (Elaboratable_Name fc n) (Elaboratable_Name _ n') +findUpdates defs (Elaborable_Name fc n) (Elaborable_Name _ n') = case !(lookupTyExact n' (gamma defs)) of - Just _ => recordUpdate fc n (Elaboratable_Name fc n') + Just _ => recordUpdate fc n (Elaborable_Name fc n') Nothing => do u <- get UPD case lookup n' (namemap u) of Nothing => put UPD ({ namemap $= ((n', n) ::) } u) - Just nm => put UPD ({ updates $= ((n, Elaboratable_Name fc nm) ::) } u) -findUpdates defs (Elaboratable_Name fc n) tm = recordUpdate fc n tm -findUpdates defs (Elaboratable_Apply _ f a) (Elaboratable_Apply _ f' a') + Just nm => put UPD ({ updates $= ((n, Elaborable_Name fc nm) ::) } u) +findUpdates defs (Elaborable_Name fc n) tm = recordUpdate fc n tm +findUpdates defs (Elaborable_Apply _ f a) (Elaborable_Apply _ f' a') = do findUpdates defs f f' findUpdates defs a a' -findUpdates defs (Elaboratable_Automatic_Apply _ f a) (Elaboratable_Automatic_Apply _ f' a') +findUpdates defs (Elaborable_Automatic_Apply _ f a) (Elaborable_Automatic_Apply _ f' a') = do findUpdates defs f f' findUpdates defs a a' -findUpdates defs (Elaboratable_Automatic_Apply _ f a) f' +findUpdates defs (Elaborable_Automatic_Apply _ f a) f' = findUpdates defs f f' -findUpdates defs f (Elaboratable_Automatic_Apply _ f' a) +findUpdates defs f (Elaborable_Automatic_Apply _ f' a) = findUpdates defs f f' -findUpdates defs (Elaboratable_Named_Apply _ f _ a) (Elaboratable_Named_Apply _ f' _ a') +findUpdates defs (Elaborable_Named_Apply _ f _ a) (Elaborable_Named_Apply _ f' _ a') = do findUpdates defs f f' findUpdates defs a a' -findUpdates defs (Elaboratable_Named_Apply _ f _ a) f' = findUpdates defs f f' -findUpdates defs f (Elaboratable_Named_Apply _ f' _ a) = findUpdates defs f f' -findUpdates defs (Elaboratable_As_Pattern _ _ _ _ f) f' = findUpdates defs f f' -findUpdates defs f (Elaboratable_As_Pattern _ _ _ _ f') = findUpdates defs f f' +findUpdates defs (Elaborable_Named_Apply _ f _ a) f' = findUpdates defs f f' +findUpdates defs f (Elaborable_Named_Apply _ f' _ a) = findUpdates defs f f' +findUpdates defs (Elaborable_As_Pattern _ _ _ _ f) f' = findUpdates defs f f' +findUpdates defs f (Elaborable_As_Pattern _ _ _ _ f') = findUpdates defs f f' findUpdates _ _ _ = pure () getUpdates : Defs -> RawImp -> RawImp -> Core (List (Name, RawImp)) @@ -265,7 +265,7 @@ mkCase {c} {u} fn orig lhs_raw -- once split and turned into a pattern) (lhs, _) <- elabTerm {c} {m} {u} fn (InLHS erased) [] (MkNested []) - Env.empty (Elaboratable_Bind_Here (getFC lhs_raw) PATTERN lhs_raw) + Env.empty (Elaborable_Bind_Here (getFC lhs_raw) PATTERN lhs_raw) Nothing -- Revert all public back to false setAllPublic False diff --git a/TTImp/Interactive/ExprSearch.idr b/TTImp/Interactive/ExprSearch.idr index 17646ba255..1cb48f9581 100644 --- a/TTImp/Interactive/ExprSearch.idr +++ b/TTImp/Interactive/ExprSearch.idr @@ -564,7 +564,7 @@ makeHelper fc rig opts env letty targetty ((locapp, ds) :: next) | _ => do log "interaction.search" 10 "No results" noResult - let helperdef = Elaboratable_Definition fc helpern (snd helper) + let helperdef = Elaborable_Definition fc helpern (snd helper) log "interaction.search" 10 $ "Def: " ++ show helperdef pure ((::) (def, helperdef :: ds) -- plus helper (do next' <- next diff --git a/TTImp/Interactive/GenerateDef.idr b/TTImp/Interactive/GenerateDef.idr index 573cc7b2f2..6879dda89a 100644 --- a/TTImp/Interactive/GenerateDef.idr +++ b/TTImp/Interactive/GenerateDef.idr @@ -41,10 +41,10 @@ uniqueRHS (PatClause fc lhs rhs) = pure $ PatClause fc lhs !(mkUniqueName rhs) where mkUniqueName : RawImp -> Core RawImp - mkUniqueName (Elaboratable_Hole fc' rhsn) + mkUniqueName (Elaborable_Hole fc' rhsn) = do defs <- get Ctxt rhsn' <- uniqueHoleName defs [] rhsn - pure (Elaboratable_Hole fc' rhsn') + pure (Elaborable_Hole fc' rhsn') mkUniqueName tm = pure tm -- it'll be a hole, but this is needed for covering uniqueRHS c = pure c @@ -84,21 +84,21 @@ expandClause loc opts n c dropLams : Nat -> RawImp -> RawImp dropLams Z tm = tm - dropLams (S k) (Elaboratable_Lambda _ _ _ _ _ sc) = dropLams k sc + dropLams (S k) (Elaborable_Lambda _ _ _ _ _ sc) = dropLams k sc dropLams _ tm = tm splittableNames : RawImp -> List Name -splittableNames (Elaboratable_Apply _ f (Elaboratable_Bind_Name _ n)) +splittableNames (Elaborable_Apply _ f (Elaborable_Bind_Name _ n)) = splittableNames f ++ [n] -splittableNames (Elaboratable_Apply _ f _) +splittableNames (Elaborable_Apply _ f _) = splittableNames f -splittableNames (Elaboratable_With_Apply _ f (Elaboratable_Bind_Name _ n)) +splittableNames (Elaborable_With_Apply _ f (Elaborable_Bind_Name _ n)) = splittableNames f ++ [n] -splittableNames (Elaboratable_With_Apply _ f _) +splittableNames (Elaborable_With_Apply _ f _) = splittableNames f -splittableNames (Elaboratable_Automatic_Apply _ f _) +splittableNames (Elaborable_Automatic_Apply _ f _) = splittableNames f -splittableNames (Elaboratable_Named_Apply _ f _ _) +splittableNames (Elaborable_Named_Apply _ f _ _) = splittableNames f splittableNames _ = [] @@ -119,26 +119,26 @@ trySplit loc lhsraw lhs rhs n valid _ = Nothing fixNames : RawImp -> RawImp - fixNames (Elaboratable_Name loc' n@(UN (Basic {}))) = Elaboratable_Bind_Name loc' n - fixNames (Elaboratable_Name loc' (MN {})) = Implicit loc' True - fixNames (Elaboratable_Apply loc' f a) = Elaboratable_Apply loc' (fixNames f) (fixNames a) - fixNames (Elaboratable_Automatic_Apply loc' f a) = Elaboratable_Automatic_Apply loc' (fixNames f) (fixNames a) - fixNames (Elaboratable_Named_Apply loc' f t a) = Elaboratable_Named_Apply loc' (fixNames f) t (fixNames a) + fixNames (Elaborable_Name loc' n@(UN (Basic {}))) = Elaborable_Bind_Name loc' n + fixNames (Elaborable_Name loc' (MN {})) = Implicit loc' True + fixNames (Elaborable_Apply loc' f a) = Elaborable_Apply loc' (fixNames f) (fixNames a) + fixNames (Elaborable_Automatic_Apply loc' f a) = Elaborable_Automatic_Apply loc' (fixNames f) (fixNames a) + fixNames (Elaborable_Named_Apply loc' f t a) = Elaborable_Named_Apply loc' (fixNames f) t (fixNames a) fixNames tm = tm updateLHS : List (Name, RawImp) -> RawImp -> RawImp - updateLHS ups (Elaboratable_Name loc' n) + updateLHS ups (Elaborable_Name loc' n) = case lookup n ups of - Nothing => Elaboratable_Name loc' n + Nothing => Elaborable_Name loc' n Just tm => fixNames tm - updateLHS ups (Elaboratable_Bind_Name loc' n) + updateLHS ups (Elaborable_Bind_Name loc' n) = case lookup n ups of - Nothing => Elaboratable_Bind_Name loc' n + Nothing => Elaborable_Bind_Name loc' n Just tm => fixNames tm - updateLHS ups (Elaboratable_Apply loc' f a) = Elaboratable_Apply loc' (updateLHS ups f) (updateLHS ups a) - updateLHS ups (Elaboratable_Automatic_Apply loc' f a) = Elaboratable_Automatic_Apply loc' (updateLHS ups f) (updateLHS ups a) - updateLHS ups (Elaboratable_Named_Apply loc' f t a) - = Elaboratable_Named_Apply loc' (updateLHS ups f) t (updateLHS ups a) + updateLHS ups (Elaborable_Apply loc' f a) = Elaborable_Apply loc' (updateLHS ups f) (updateLHS ups a) + updateLHS ups (Elaborable_Automatic_Apply loc' f a) = Elaborable_Automatic_Apply loc' (updateLHS ups f) (updateLHS ups a) + updateLHS ups (Elaborable_Named_Apply loc' f t a) + = Elaborable_Named_Apply loc' (updateLHS ups f) t (updateLHS ups a) updateLHS ups tm = tm generateSplits : {auto m : Ref MD Metadata} -> @@ -153,7 +153,7 @@ generateSplits loc opts fn (WithClause fc lhs rig wval prf flags cs) = pure [] generateSplits loc opts fn (PatClause fc lhs rhs) = do (lhstm, _) <- elabTerm fn (InLHS linear) [] (MkNested []) Env.empty - (Elaboratable_Bind_Here loc PATTERN lhs) Nothing + (Elaborable_Bind_Here loc PATTERN lhs) Nothing let splitnames = if ltor opts then splittableNames lhs else reverse (splittableNames lhs) @@ -229,8 +229,8 @@ makeDefFromType loc opts n envlen ty rhshole <- uniqueHoleName defs [] (fnName False n ++ "_rhs") let initcs = PatClause loc - (apply (Elaboratable_Name loc n) (pre_env ++ (map (Elaboratable_Bind_Name loc . UN . Basic) argns))) - (Elaboratable_Hole loc rhshole) + (apply (Elaborable_Name loc n) (pre_env ++ (map (Elaborable_Bind_Name loc . UN . Basic) argns))) + (Elaborable_Hole loc rhshole) let Just nidx = getNameID n (gamma defs) | Nothing => undefinedName loc n cs' <- mkSplits loc opts nidx initcs diff --git a/TTImp/Interactive/Intro.idr b/TTImp/Interactive/Intro.idr index 9b78c7baac..45d02046da 100644 --- a/TTImp/Interactive/Intro.idr +++ b/TTImp/Interactive/Intro.idr @@ -31,15 +31,15 @@ parameters (hole : Name) (env : Env Term lhsCtxt) - introLam : Name -> RigCount -> Term lhsCtxt -> Core Kinded_Elaboratable_Term + introLam : Name -> RigCount -> Term lhsCtxt -> Core Kinded_Elaborable_Term introLam x rig ty = do ty <- unelab env ty defs <- get Ctxt new_hole <- uniqueHoleName defs [] (nameRoot hole) - let iintrod = Elaboratable_Lambda replFC rig Explicit (Just x) ty (Elaboratable_Hole replFC new_hole) + let iintrod = Elaborable_Lambda replFC rig Explicit (Just x) ty (Elaborable_Hole replFC new_hole) pure iintrod - introCon : Name -> Term lhsCtxt -> Core (List Kinded_Elaboratable_Term) + introCon : Name -> Term lhsCtxt -> Core (List Kinded_Elaborable_Term) introCon n ty = do defs <- get Ctxt ust <- get UST @@ -71,7 +71,7 @@ parameters pure (catMaybes ics) export - intro : Term lhsCtxt -> Core (List Kinded_Elaboratable_Term) + intro : Term lhsCtxt -> Core (List Kinded_Elaborable_Term) -- structural cases intro (Bind _ x (Let _ _ ty val) sc) = toList <$> intro (subst val sc) intro (TDelayed _ _ t) = intro t diff --git a/TTImp/Interactive/MakeLemma.idr b/TTImp/Interactive/MakeLemma.idr index 47f562ae29..6b68969473 100644 --- a/TTImp/Interactive/MakeLemma.idr +++ b/TTImp/Interactive/MakeLemma.idr @@ -65,16 +65,16 @@ mkType : FC -> List (Name, Maybe Name, PiInfo RawImp, RigCount, RawImp) -> RawImp -> RawImp mkType loc [] ret = ret mkType loc ((_, n, p, c, ty) :: rest) ret - = Elaboratable_Dependent_Function_Type loc c p n ty (mkType loc rest ret) + = Elaborable_Dependent_Function_Type loc c p n ty (mkType loc rest ret) mkApp : FC -> Name -> List (Name, Maybe Name, PiInfo RawImp, RigCount, RawImp) -> RawImp mkApp loc n args - = apply (Elaboratable_Name loc n) (mapMaybe getArg args) + = apply (Elaborable_Name loc n) (mapMaybe getArg args) where getArg : (Name, Maybe Name, PiInfo RawImp, RigCount, RawImp) -> Maybe RawImp - getArg (x, _, Explicit, _, _) = Just (Elaboratable_Name loc x) + getArg (x, _, Explicit, _, _) = Just (Elaborable_Name loc x) getArg _ = Nothing -- Return a top level type for the lemma, and an expression which applies diff --git a/TTImp/Parser.idr b/TTImp/Parser.idr index 02bb95269c..f77fefa2f9 100644 --- a/TTImp/Parser.idr +++ b/TTImp/Parser.idr @@ -36,15 +36,15 @@ atom fname = do start <- location x <- constant end <- location - pure (Elaboratable_Primitive_Value (MkFC fname start end) x) + pure (Elaborable_Primitive_Value (MkFC fname start end) x) <|> do start <- location str <- simpleStr end <- location - pure (Elaboratable_Primitive_Value (MkFC fname start end) (Str str)) + pure (Elaborable_Primitive_Value (MkFC fname start end) (Str str)) <|> do start <- location exactIdent "Type" end <- location - pure (Elaboratable_Type_Universe (MkFC fname start end)) + pure (Elaborable_Type_Universe (MkFC fname start end)) <|> do start <- location symbol "_" end <- location @@ -56,20 +56,20 @@ atom fname <|> do start <- location pragma "search" end <- location - pure (Elaboratable_Search (MkFC fname start end) 1000) + pure (Elaborable_Search (MkFC fname start end) 1000) <|> do start <- location x <- name end <- location - pure (Elaboratable_Name (MkFC fname start end) x) + pure (Elaborable_Name (MkFC fname start end) x) <|> do start <- location symbol "$" x <- userName end <- location - pure (Elaboratable_Bind_Name (MkFC fname start end) x) + pure (Elaborable_Bind_Name (MkFC fname start end) x) <|> do start <- location x <- holeName end <- location - pure (Elaboratable_Hole (MkFC fname start end) x) + pure (Elaborable_Hole (MkFC fname start end) x) visOption : Rule Visibility visOption @@ -169,11 +169,11 @@ mutual RawImp applyExpImp start end f [] = f applyExpImp start end f (Left exp :: args) - = applyExpImp start end (Elaboratable_Apply (MkFC fname start end) f exp) args + = applyExpImp start end (Elaborable_Apply (MkFC fname start end) f exp) args applyExpImp start end f (Right (Just n, imp) :: args) - = applyExpImp start end (Elaboratable_Named_Apply (MkFC fname start end) f n imp) args + = applyExpImp start end (Elaborable_Named_Apply (MkFC fname start end) f n imp) args applyExpImp start end f (Right (Nothing, imp) :: args) - = applyExpImp start end (Elaboratable_Automatic_Apply (MkFC fname start end) f imp) args + = applyExpImp start end (Elaborable_Automatic_Apply (MkFC fname start end) f imp) args argExpr : OriginDesc -> IndentInfo -> Rule (Either RawImp (Maybe Name, RawImp)) @@ -197,7 +197,7 @@ mutual pure (Just x, tm)) <|> (do symbol "}" end <- location - pure (Just x, Elaboratable_Name (MkFC fname start end) x)) + pure (Just x, Elaborable_Name (MkFC fname start end) x)) <|> do symbol "@{" commit tm <- expr fname indents @@ -212,7 +212,7 @@ mutual symbol "@" pat <- simpleExpr fname indents end <- location - pure (Elaboratable_As_Pattern (MkFC fname start end) (MkFC fname start nameEnd) UseRight x pat) + pure (Elaborable_As_Pattern (MkFC fname start end) (MkFC fname start nameEnd) UseRight x pat) simpleExpr : OriginDesc -> IndentInfo -> Rule RawImp simpleExpr fname indents @@ -242,7 +242,7 @@ mutual RawImp -> RawImp pibindAll fc p [] scope = scope pibindAll fc p (ty :: rest) scope - = Elaboratable_Dependent_Function_Type fc ty.rig p (map val ty.mName) ty.val (pibindAll fc p rest scope) + = Elaborable_Dependent_Function_Type fc ty.rig p (map val ty.mName) ty.val (pibindAll fc p rest scope) bindList : OriginDesc -> FilePos -> IndentInfo -> Rule (List (RigCount, Name, RawImp)) @@ -350,7 +350,7 @@ mutual bindAll : FC -> List (RigCount, Name, RawImp) -> RawImp -> RawImp bindAll fc [] scope = scope bindAll fc ((rig, n, ty) :: rest) scope - = Elaboratable_Lambda fc rig Explicit (Just n) ty (bindAll fc rest scope) + = Elaborable_Lambda fc rig Explicit (Just n) ty (bindAll fc rest scope) let_ : OriginDesc -> IndentInfo -> Rule RawImp let_ fname indents @@ -367,7 +367,7 @@ mutual scope <- typeExpr fname indents end <- location pure (let fc = MkFC fname start end in - Elaboratable_Binding fc (boundToFC fname n) rig n.val (Implicit fc False) val scope) + Elaborable_Binding fc (boundToFC fname n) rig n.val (Implicit fc False) val scope) <|> do start <- location keyword "let" ds <- block (topDecl fname) @@ -375,7 +375,7 @@ mutual keyword "in" scope <- typeExpr fname indents end <- location - pure (Elaboratable_Local_Definitions (MkFC fname start end) (collectDefs ds) scope) + pure (Elaborable_Local_Definitions (MkFC fname start end) (collectDefs ds) scope) case_ : OriginDesc -> IndentInfo -> Rule RawImp case_ fname indents @@ -387,7 +387,7 @@ mutual alts <- block (caseAlt fname) end <- location pure (let fc = MkFC fname start end in - Elaboratable_Case fc opts scr (Implicit fc False) alts) + Elaborable_Case fc opts scr (Implicit fc False) alts) caseAlt : OriginDesc -> IndentInfo -> Rule ImpClause caseAlt fname indents @@ -419,14 +419,14 @@ mutual symbol "}" sc <- expr fname indents end <- location - pure (Elaboratable_Record_Update (MkFC fname start end) (forget fs) sc) + pure (Elaborable_Record_Update (MkFC fname start end) (forget fs) sc) - field : OriginDesc -> IndentInfo -> Rule Elaboratable_Field_Update + field : OriginDesc -> IndentInfo -> Rule Elaborable_Field_Update field fname indents = do path <- sepBy1 (symbol "->") unqualifiedName - upd <- (do symbol "="; pure Elaboratable_Set_Field) + upd <- (do symbol "="; pure Elaborable_Set_Field) <|> - (do symbol "$="; pure Elaboratable_Apply_To_Field) + (do symbol "$="; pure Elaborable_Apply_To_Field) val <- appExpr fname indents pure (upd (forget path) val) @@ -438,7 +438,7 @@ mutual keyword "in" tm <- expr fname indents end <- location - pure (Elaboratable_Rewrite (MkFC fname start end) rule tm) + pure (Elaborable_Rewrite (MkFC fname start end) rule tm) lazy : OriginDesc -> IndentInfo -> Rule RawImp lazy fname indents @@ -446,22 +446,22 @@ mutual exactIdent "Lazy" tm <- simpleExpr fname indents end <- location - pure (Elaboratable_Delayed_Type (MkFC fname start end) LLazy tm) + pure (Elaborable_Delayed_Type (MkFC fname start end) LLazy tm) <|> do start <- location exactIdent "Inf" tm <- simpleExpr fname indents end <- location - pure (Elaboratable_Delayed_Type (MkFC fname start end) LInf tm) + pure (Elaborable_Delayed_Type (MkFC fname start end) LInf tm) <|> do start <- location exactIdent "Delay" tm <- simpleExpr fname indents end <- location - pure (Elaboratable_Delay (MkFC fname start end) tm) + pure (Elaborable_Delay (MkFC fname start end) tm) <|> do start <- location exactIdent "Force" tm <- simpleExpr fname indents end <- location - pure (Elaboratable_Force (MkFC fname start end) tm) + pure (Elaborable_Force (MkFC fname start end) tm) binder : OriginDesc -> IndentInfo -> Rule RawImp @@ -488,7 +488,7 @@ mutual mkPi : FilePos -> FilePos -> RawImp -> List (PiInfo RawImp, RawImp) -> RawImp mkPi start end arg [] = arg mkPi start end arg ((exp, a) :: as) - = Elaboratable_Dependent_Function_Type (MkFC fname start end) top exp Nothing arg + = Elaborable_Dependent_Function_Type (MkFC fname start end) top exp Nothing arg (mkPi start end a as) export @@ -541,10 +541,10 @@ mutual pure (!(getFn lhs), ImpossibleClause fc lhs) where getFn : RawImp -> EmptyRule Name - getFn (Elaboratable_Name _ n) = pure n - getFn (Elaboratable_Apply _ f a) = getFn f - getFn (Elaboratable_Automatic_Apply _ f a) = getFn f - getFn (Elaboratable_Named_Apply _ f _ a) = getFn f + getFn (Elaborable_Name _ n) = pure n + getFn (Elaborable_Apply _ f a) = getFn f + getFn (Elaborable_Automatic_Apply _ f a) = getFn f + getFn (Elaborable_Named_Apply _ f _ a) = getFn f getFn _ = fail "Not a function application" clause : Nat -> OriginDesc -> IndentInfo -> Rule (Name, ImpClause) @@ -558,7 +558,7 @@ mutual where applyArgs : RawImp -> List (FC, RawImp) -> RawImp applyArgs f [] = f - applyArgs f ((fc, a) :: args) = applyArgs (Elaboratable_Apply fc f a) args + applyArgs f ((fc, a) :: args) = applyArgs (Elaborable_Apply fc f a) args parseWithArg : Rule (FC, RawImp) parseWithArg @@ -573,7 +573,7 @@ definition fname indents = do start <- location nd <- clause 0 fname indents end <- location - pure (Elaboratable_Definition (MkFC fname start end) (fst nd) [snd nd]) + pure (Elaborable_Definition (MkFC fname start end) (fst nd) [snd nd]) dataOpt : Rule DataOpt dataOpt @@ -627,7 +627,7 @@ recordParam fname indents <|> do n <- withFC name pure [ Mk [top, n] (MkPiBindData Explicit (Implicit n.fc False)) ] -fieldDecl : OriginDesc -> IndentInfo -> Rule (List Elaboratable_Field) +fieldDecl : OriginDesc -> IndentInfo -> Rule (List Elaborable_Field) fieldDecl fname indents = do symbol "{" commit @@ -639,7 +639,7 @@ fieldDecl fname indents atEnd indents pure fs where - fieldBody : PiInfo RawImp -> Rule (List Elaboratable_Field) + fieldBody : PiInfo RawImp -> Rule (List Elaborable_Field) fieldBody p = do start <- location ns <- sepBy1 (symbol ",") (withFC userName) @@ -666,7 +666,7 @@ recordDecl fname indents flds <- assert_total (blockAfter col (fieldDecl fname)) end <- location pure (let fc = MkFC fname start end - in Elaboratable_Record_Declaration fc Nothing vis mbtot + in Elaborable_Record_Declaration fc Nothing vis mbtot (Mk [fc] $ MkImpRecord (Mk [n] params) (Mk [dc, opts] (concat flds)))) namespaceDecl : Rule Namespace @@ -688,16 +688,16 @@ directive fname indents commit lvl <- logLevel atEnd indents - pure (Elaboratable_Logging lvl) + pure (Elaborable_Logging lvl) <|> do b <- bounds (do pragma "builtin" commit t <- builtinType n <- name pure (t, n)) (t, n) <- pure b.val - pure $ Elaboratable_Builtin_Declaration (boundToFC fname b) t n + pure $ Elaborable_Builtin_Declaration (boundToFC fname b) t n - {- Can't do Elaboratable_Pragma due to lack of Ref Ctxt. Should we worry about this? + {- Can't do Elaborable_Pragma due to lack of Ref Ctxt. Should we worry about this? <|> do pragma "pair" commit start <- location @@ -706,7 +706,7 @@ directive fname indents s <- name end <- location pure (let fc = MkFC fname start end in - Elaboratable_Pragma (\nest, env => setPair {c} fc p f s)) + Elaborable_Pragma (\nest, env => setPair {c} fc p f s)) <|> do pragma "rewrite" commit start <- location @@ -714,7 +714,7 @@ directive fname indents rw <- name end <- location pure (let fc = MkFC fname start end in - Elaboratable_Pragma (\c, nest, env => setRewrite {c} fc eq rw)) + Elaborable_Pragma (\c, nest, env => setRewrite {c} fc eq rw)) -} -- Declared at the top -- topDecl : OriginDesc -> IndentInfo -> Rule ImpDecl @@ -723,12 +723,12 @@ topDecl fname indents (vis,mbtot) <- dataVisOpt dat <- dataDecl fname indents end <- location - pure (Elaboratable_Data_Declaration (MkFC fname start end) vis mbtot dat) + pure (Elaborable_Data_Declaration (MkFC fname start end) vis mbtot dat) <|> do start <- location ns <- namespaceDecl ds <- assert_total (nonEmptyBlock (topDecl fname)) end <- location - pure (Elaboratable_Namespace_Block (MkFC fname start end) ns (forget ds)) + pure (Elaborable_Namespace_Block (MkFC fname start end) ns (forget ds)) <|> do start <- location visOpts <- many visOpt vis <- getVisibility Nothing visOpts @@ -737,7 +737,7 @@ topDecl fname indents rig <- getMult m claim <- tyDecl fname indents end <- location - pure (Elaboratable_Claim (MkFCVal (MkFC fname start end) $ Make_Elaboratable_Claim_Data rig vis opts claim)) + pure (Elaborable_Claim (MkFCVal (MkFC fname start end) $ Make_Elaborable_Claim_Data rig vis opts claim)) <|> recordDecl fname indents <|> directive fname indents <|> definition fname indents @@ -745,9 +745,9 @@ topDecl fname indents -- Declared at the top -- collectDefs : List ImpDecl -> List ImpDecl collectDefs [] = [] -collectDefs (Elaboratable_Definition loc fn cs :: ds) +collectDefs (Elaborable_Definition loc fn cs :: ds) = let (cs', rest) = spanMap (isClause fn) ds in - Elaboratable_Definition loc fn (cs ++ cs') :: assert_total (collectDefs rest) + Elaborable_Definition loc fn (cs ++ cs') :: assert_total (collectDefs rest) where spanMap : (a -> Maybe (List b)) -> List a -> (List b, List a) spanMap f [] = ([], []) @@ -757,13 +757,13 @@ collectDefs (Elaboratable_Definition loc fn cs :: ds) (ys, zs) => (y ++ ys, zs) isClause : Name -> ImpDecl -> Maybe (List ImpClause) - isClause n (Elaboratable_Definition _ n' cs) + isClause n (Elaborable_Definition _ n' cs) = if n == n' then Just cs else Nothing isClause n _ = Nothing -collectDefs (Elaboratable_Namespace_Block loc ns nds :: ds) - = Elaboratable_Namespace_Block loc ns (collectDefs nds) :: collectDefs ds -collectDefs (Elaboratable_Expected_Failure loc msg nds :: ds) - = Elaboratable_Expected_Failure loc msg (collectDefs nds) :: collectDefs ds +collectDefs (Elaborable_Namespace_Block loc ns nds :: ds) + = Elaborable_Namespace_Block loc ns (collectDefs nds) :: collectDefs ds +collectDefs (Elaborable_Expected_Failure loc msg nds :: ds) + = Elaborable_Expected_Failure loc msg (collectDefs nds) :: collectDefs ds collectDefs (d :: ds) = d :: collectDefs ds diff --git a/TTImp/PartialEval.idr b/TTImp/PartialEval.idr index b49adea377..7b7bf9f836 100644 --- a/TTImp/PartialEval.idr +++ b/TTImp/PartialEval.idr @@ -135,8 +135,8 @@ getSpecPats fc pename fn stk fnty args sargs pats -- on the lhs, and using the specialised function application on the rhs. -- Then, this will get evaluated on elaboration. dynnames <- mkDynNames args - let lhs = apply (Elaboratable_Name fc pename) (map (Elaboratable_Bind_Name fc) dynnames) - rhs <- mkRHSargs fnty (Elaboratable_Name fc fn) dynnames args + let lhs = apply (Elaborable_Name fc pename) (map (Elaborable_Bind_Name fc) dynnames) + rhs <- mkRHSargs fnty (Elaborable_Name fc fn) dynnames args pure (Just [PatClause fc lhs rhs]) where mkDynNames : List (Nat, ArgMode) -> Core (List Name) @@ -152,51 +152,51 @@ getSpecPats fc pename fn stk fnty args sargs pats mkRHSargs (NBind _ x (Pi _ _ Explicit _) sc) app (a :: as) ((_, Dynamic) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) - mkRHSargs sc' (Elaboratable_Apply fc app (Elaboratable_Name fc a)) as ds + mkRHSargs sc' (Elaborable_Apply fc app (Elaborable_Name fc a)) as ds mkRHSargs (NBind _ x (Pi {}) sc) app (a :: as) ((_, Dynamic) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) - mkRHSargs sc' (Elaboratable_Named_Apply fc app x (Elaboratable_Name fc a)) as ds + mkRHSargs sc' (Elaborable_Named_Apply fc app x (Elaborable_Name fc a)) as ds mkRHSargs (NBind _ x (Pi _ _ Explicit _) sc) app as ((_, Static tm) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) tm' <- unelabNoSugar Env.empty tm - mkRHSargs sc' (Elaboratable_Apply fc app (map rawName tm')) as ds + mkRHSargs sc' (Elaborable_Apply fc app (map rawName tm')) as ds mkRHSargs (NBind _ x (Pi _ _ Implicit _) sc) app as ((_, Static tm) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) tm' <- unelabNoSugar Env.empty tm - mkRHSargs sc' (Elaboratable_Named_Apply fc app x (map rawName tm')) as ds + mkRHSargs sc' (Elaborable_Named_Apply fc app x (map rawName tm')) as ds mkRHSargs (NBind _ _ (Pi _ _ AutoImplicit _) sc) app as ((_, Static tm) :: ds) = do defs <- get Ctxt sc' <- sc defs (toClosure defaultOpts Env.empty (Erased fc Placeholder)) tm' <- unelabNoSugar Env.empty tm - mkRHSargs sc' (Elaboratable_Automatic_Apply fc app (map rawName tm')) as ds + mkRHSargs sc' (Elaborable_Automatic_Apply fc app (map rawName tm')) as ds -- Type will depend on the value here (we assume a variadic function) but -- the argument names are still needed mkRHSargs ty app (a :: as) ((_, Dynamic) :: ds) - = mkRHSargs ty (Elaboratable_Apply fc app (Elaboratable_Name fc a)) as ds + = mkRHSargs ty (Elaborable_Apply fc app (Elaborable_Name fc a)) as ds mkRHSargs _ app _ _ = pure app getRawArgs : List (Arg' Name) -> RawImp -> List (Arg' Name) - getRawArgs args (Elaboratable_Apply fc f arg) = getRawArgs (Explicit fc arg :: args) f - getRawArgs args (Elaboratable_Named_Apply fc f n arg) + getRawArgs args (Elaborable_Apply fc f arg) = getRawArgs (Explicit fc arg :: args) f + getRawArgs args (Elaborable_Named_Apply fc f n arg) = getRawArgs (Named fc n arg :: args) f - getRawArgs args (Elaboratable_Automatic_Apply fc f arg) + getRawArgs args (Elaborable_Automatic_Apply fc f arg) = getRawArgs (Auto fc arg :: args) f getRawArgs args tm = args reapply : RawImp -> List (Arg' Name) -> RawImp reapply f [] = f - reapply f (Explicit fc arg :: args) = reapply (Elaboratable_Apply fc f arg) args + reapply f (Explicit fc arg :: args) = reapply (Elaborable_Apply fc f arg) args reapply f (Named fc n arg :: args) - = reapply (Elaboratable_Named_Apply fc f n arg) args + = reapply (Elaborable_Named_Apply fc f n arg) args reapply f (Auto fc arg :: args) - = reapply (Elaboratable_Automatic_Apply fc f arg) args + = reapply (Elaborable_Automatic_Apply fc f arg) args dropArgs : Name -> RawImp -> RawImp - dropArgs pename tm = reapply (Elaboratable_Name fc pename) (dropSpec 0 sargs (getRawArgs [] tm)) + dropArgs pename tm = reapply (Elaborable_Name fc pename) (dropSpec 0 sargs (getRawArgs [] tm)) unelabPat : Name -> (vs ** (Env Term vs, Term vs, Term vs)) -> Core ImpClause @@ -209,7 +209,7 @@ getSpecPats fc pename fn stk fnty args sargs pats rhs <- normaliseArgHoles defs env rhs rhs <- unelabNoSugar env rhs let rhs = flip mapTTImp rhs $ \case - Elaboratable_Hole fc _ => Implicit fc False + Elaborable_Hole fc _ => Implicit fc False tm => tm pure (PatClause fc lhs' (map rawName rhs)) @@ -306,7 +306,7 @@ mkSpecDef {vars} fc gdef pename sargs fn stk log "specialise" 5 $ "New patterns for " ++ show pename ++ ":\n" ++ showSep "\n" (map showPat newpats) processDecl [InPartialEval] (MkNested []) Env.empty - (Elaboratable_Definition fc (Resolved peidx) newpats) + (Elaborable_Definition fc (Resolved peidx) newpats) setAllPublic False pure peapp) -- If the partially evaluated definition fails, just use the initial @@ -342,10 +342,10 @@ mkSpecDef {vars} fc gdef pename sargs fn stk getAllRefs ns [] = ns updateApp : Name -> RawImp -> RawImp - updateApp n (Elaboratable_Apply fc f a) = Elaboratable_Apply fc (updateApp n f) a - updateApp n (Elaboratable_Automatic_Apply fc f a) = Elaboratable_Automatic_Apply fc (updateApp n f) a - updateApp n (Elaboratable_Named_Apply fc f m a) = Elaboratable_Named_Apply fc (updateApp n f) m a - updateApp n f = Elaboratable_Name fc n + updateApp n (Elaborable_Apply fc f a) = Elaborable_Apply fc (updateApp n f) a + updateApp n (Elaborable_Automatic_Apply fc f a) = Elaborable_Automatic_Apply fc (updateApp n f) a + updateApp n (Elaborable_Named_Apply fc f m a) = Elaborable_Named_Apply fc (updateApp n f) m a + updateApp n f = Elaborable_Name fc n unelabDef : (vs ** (Env Term vs, Term vs, Term vs)) -> Core ImpClause diff --git a/TTImp/ProcessData.idr b/TTImp/ProcessData.idr index 8d8d800c7c..435af5b43b 100644 --- a/TTImp/ProcessData.idr +++ b/TTImp/ProcessData.idr @@ -66,17 +66,17 @@ checkFamily loc cn tn env nf _ => throw $ BadDataConType loc cn tn updateNS : Name -> Name -> RawImp -> RawImp -updateNS orig ns (Elaboratable_Dependent_Function_Type fc c p n ty sc) = Elaboratable_Dependent_Function_Type fc c p n ty (updateNS orig ns sc) +updateNS orig ns (Elaborable_Dependent_Function_Type fc c p n ty sc) = Elaborable_Dependent_Function_Type fc c p n ty (updateNS orig ns sc) updateNS orig ns tm = updateNSApp tm where updateNSApp : RawImp -> RawImp - updateNSApp (Elaboratable_Name fc n) -- data type type, must be defined in this namespace + updateNSApp (Elaborable_Name fc n) -- data type type, must be defined in this namespace = if n == orig - then Elaboratable_Name fc ns - else Elaboratable_Name fc n - updateNSApp (Elaboratable_Apply fc f arg) = Elaboratable_Apply fc (updateNSApp f) arg - updateNSApp (Elaboratable_Automatic_Apply fc f arg) = Elaboratable_Automatic_Apply fc (updateNSApp f) arg - updateNSApp (Elaboratable_Named_Apply fc f n arg) = Elaboratable_Named_Apply fc (updateNSApp f) n arg + then Elaborable_Name fc ns + else Elaborable_Name fc n + updateNSApp (Elaborable_Apply fc f arg) = Elaborable_Apply fc (updateNSApp f) arg + updateNSApp (Elaborable_Automatic_Apply fc f arg) = Elaborable_Automatic_Apply fc (updateNSApp f) arg + updateNSApp (Elaborable_Named_Apply fc f n arg) = Elaborable_Named_Apply fc (updateNSApp f) n arg updateNSApp t = t checkCon : {vars : _} -> @@ -104,7 +104,7 @@ checkCon {vars} opts nest env vis tn_in tn ty_raw ty <- wrapErrorC opts (InCon cn_in) $ checkTerm !(resolveName cn) InType opts nest env - (Elaboratable_Bind_Here fc (PI erased) ty_raw) + (Elaborable_Bind_Here fc (PI erased) ty_raw) (gType fc u) -- Check 'ty' returns something in the right family @@ -414,7 +414,7 @@ processData {vars} eopts nest env fc def_vis mbtot (MkImpLater dfc n_in ty_raw) (ty, _) <- wrapErrorC eopts (InCon $ MkFCVal dfc n) $ elabTerm !(resolveName n) InType eopts nest env - (Elaboratable_Bind_Here fc (PI erased) ty_raw) + (Elaborable_Bind_Here fc (PI erased) ty_raw) (Just (gType dfc u)) let fullty = abstractEnvType dfc env ty logTermNF "declare.data" 5 ("data " ++ show n) Env.empty fullty @@ -456,7 +456,7 @@ processData {vars} eopts nest env fc def_vis mbtot (MkImpData dfc n_in mty_raw o (ty, _) <- wrapErrorC eopts (InCon $ MkFCVal fc n) $ elabTerm !(resolveName n) InType eopts nest env - (Elaboratable_Bind_Here fc (PI erased) ty_raw) + (Elaborable_Bind_Here fc (PI erased) ty_raw) (Just (gType dfc u)) checkIsType fc n env !(nf defs env ty) diff --git a/TTImp/ProcessDecls.idr b/TTImp/ProcessDecls.idr index 58eedbe83a..5d55d5be7a 100644 --- a/TTImp/ProcessDecls.idr +++ b/TTImp/ProcessDecls.idr @@ -110,30 +110,30 @@ process : {vars : _} -> {auto o : Ref ROpts REPLOpts} -> List ElabOpt -> NestedNames vars -> Env Term vars -> ImpDecl -> Core () -process eopts nest env (Elaboratable_Claim dat@(MkWithData fc (Make_Elaboratable_Claim_Data rig vis opts ty))) +process eopts nest env (Elaborable_Claim dat@(MkWithData fc (Make_Elaborable_Claim_Data rig vis opts ty))) = processType eopts nest env dat.fc rig vis opts ty -process eopts nest env (Elaboratable_Data_Declaration fc vis mbtot ddef) +process eopts nest env (Elaborable_Data_Declaration fc vis mbtot ddef) = processData eopts nest env fc vis mbtot ddef -process eopts nest env (Elaboratable_Definition fc fname def) +process eopts nest env (Elaborable_Definition fc fname def) = processDef eopts nest env fc fname def -process eopts nest env (Elaboratable_Parameter_Block fc ps decls) +process eopts nest env (Elaborable_Parameter_Block fc ps decls) = processParams nest env fc (forget ps) decls -process eopts nest env (Elaboratable_Record_Declaration fc ns vis mbtot rec) +process eopts nest env (Elaborable_Record_Declaration fc ns vis mbtot rec) = processRecord eopts nest env ns vis mbtot rec -process eopts nest env (Elaboratable_Expected_Failure fc msg decls) +process eopts nest env (Elaborable_Expected_Failure fc msg decls) = processFailing eopts nest env fc msg decls -process eopts nest env (Elaboratable_Namespace_Block fc ns decls) +process eopts nest env (Elaborable_Namespace_Block fc ns decls) = withExtendedNS ns $ traverse_ (processDecl eopts nest env) decls -process eopts nest env (Elaboratable_Transformation fc n lhs rhs) +process eopts nest env (Elaborable_Transformation fc n lhs rhs) = processTransform eopts nest env fc n lhs rhs -process eopts nest env (Elaboratable_Run_Elaborator_Declaration fc tm) +process eopts nest env (Elaborable_Run_Elaborator_Declaration fc tm) = processRunElab eopts nest env fc tm -process eopts nest env (Elaboratable_Pragma _ _ act) +process eopts nest env (Elaborable_Pragma _ _ act) = act nest env -process eopts nest env (Elaboratable_Logging lvl) +process eopts nest env (Elaborable_Logging lvl) = addLogLevel (uncurry unsafeMkLogLevel <$> lvl) -process eopts nest env (Elaboratable_Builtin_Declaration fc type name) +process eopts nest env (Elaborable_Builtin_Declaration fc type name) = processBuiltin nest env fc type name TTImp.Elab.Check.processDecl = process @@ -177,12 +177,12 @@ processTTImpDecls {vars} nest env decls -- bind implicits to make raw TTImp source a bit friendlier bindNames : ImpDecl -> Core ImpDecl - bindNames (Elaboratable_Claim dat@(MkWithData fc (Make_Elaboratable_Claim_Data c vis opts ty))) + bindNames (Elaborable_Claim dat@(MkWithData fc (Make_Elaborable_Claim_Data c vis opts ty))) = do ty' <- bindTypeNames dat.fc [] (toList vars) ty.val - pure (Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data c vis opts ({val := ty'} ty)))) - bindNames (Elaboratable_Data_Declaration fc vis mbtot d) + pure (Elaborable_Claim (MkWithData fc (Make_Elaborable_Claim_Data c vis opts ({val := ty'} ty)))) + bindNames (Elaborable_Data_Declaration fc vis mbtot d) = do d' <- bindDataNames d - pure (Elaboratable_Data_Declaration fc vis mbtot d') + pure (Elaborable_Data_Declaration fc vis mbtot d') bindNames d = pure d export diff --git a/TTImp/ProcessDef.idr b/TTImp/ProcessDef.idr index 2f52605af1..e604c4cff2 100644 --- a/TTImp/ProcessDef.idr +++ b/TTImp/ProcessDef.idr @@ -322,7 +322,7 @@ checkLHS {vars} trans mult n opts nest env fc lhs_in (lhstm, lhstyg) <- wrapErrorC opts (InLHS fc !(getFullName (Resolved n))) $ elabTerm n lhsMode opts nest env - (Elaboratable_Bind_Here fc PATTERN lhs) Nothing + (Elaborable_Bind_Here fc PATTERN lhs) Nothing logTerm "declare.def.lhs" 5 "Checked LHS term" lhstm lhsty <- getTerm lhstyg @@ -399,7 +399,7 @@ checkClause mult vis totreq hashit n opts nest env (ImpossibleClause fc lhs) logEnv "declare.def.clause.impossible" 5 "In env" env (lhstm, lhstyg) <- elabTerm n (InLHS mult) opts nest env - (Elaboratable_Bind_Here fc COVERAGE lhs) Nothing + (Elaborable_Bind_Here fc COVERAGE lhs) Nothing defs <- get Ctxt lhs <- normaliseHoles defs env lhstm if !(hasEmptyPat defs env lhs) @@ -513,17 +513,17 @@ checkClause {vars} mult vis totreq hashit n opts nest env vars wtype (specified vis) None)) let toWarg : Maybe (PiInfo RawImp, Name) -> List (Maybe Name, RawImp) - := flip maybe (\pn => [(Nothing, Elaboratable_Name vfc (snd pn))]) $ + := flip maybe (\pn => [(Nothing, Elaborable_Name vfc (snd pn))]) $ (Nothing, wval_raw) :: case mprf of Nothing => [] Just _ => let fc = emptyFC in - let refl = Elaboratable_Name fc (NS builtinNS (UN $ Basic "Refl")) in - [(map snd mprf, Elaboratable_Named_Apply fc refl (UN $ Basic "x") wval_raw)] + let refl = Elaborable_Name fc (NS builtinNS (UN $ Basic "Refl")) in + [(map snd mprf, Elaborable_Named_Apply fc refl (UN $ Basic "x") wval_raw)] - let rhs_in = gapply (Elaboratable_Name vfc wname) - $ map (\ nm => (Nothing, Elaboratable_Name vfc nm)) envns + let rhs_in = gapply (Elaborable_Name vfc wname) + $ map (\ nm => (Nothing, Elaborable_Name vfc nm)) envns ++ concatMap toWarg wargNames log "declare.def.clause.with" 3 $ "Applying to with argument " ++ show rhs_in @@ -539,7 +539,7 @@ checkClause {vars} mult vis totreq hashit n opts nest env nestname <- applyEnv env wname let nest'' = { names $= (nestname ::) } nest - let wdef = Elaboratable_Definition ifc wname cs' + let wdef = Elaborable_Definition ifc wname cs' processDecl [] nest'' env wdef pure (Right (MkClause env' lhspat rhs)) @@ -819,8 +819,8 @@ isAlias : RawImp -> Maybe ((FC, Name) -- head symbol , List (FC, (FC, Name))) -- pattern variables isAlias lhs = do let (hd, apps) = getFnArgs lhs [] - hd <- is_elaboratable_name hd - args <- traverse (isExplicit >=> bitraverse pure is_elaboratable_bound_name) apps + hd <- is_elaborable_name hd + args <- traverse (isExplicit >=> bitraverse pure is_elaborable_bound_name) apps pure (hd, args) lookupOrAddAlias : {vars : _} -> @@ -870,7 +870,7 @@ lookupOrAddAlias eopts nest env fc n [cl@(PatClause _ lhs _)] holeyType [] = Implicit fc False holeyType ((xfc, x) :: xs) = let xfc = virtualiseFC xfc in - Elaboratable_Dependent_Function_Type xfc top Explicit (Just x) (Implicit xfc False) + Elaborable_Dependent_Function_Type xfc top Explicit (Just x) (Implicit xfc False) $ holeyType xs lookupOrAddAlias _ _ _ fc n _ @@ -1009,7 +1009,7 @@ processDef opts nest env fc n_in cs_in (_, lhstm) <- bindNames False itm setUnboundImplicits autoimp (lhstm, _) <- elabTerm n (InLHS mult) [] (MkNested []) Env.empty - (Elaboratable_Bind_Here fc COVERAGE lhstm) Nothing + (Elaborable_Bind_Here fc COVERAGE lhstm) Nothing defs <- get Ctxt lhs <- normaliseHoles defs Env.empty lhstm if !(hasEmptyPat defs Env.empty lhs) diff --git a/TTImp/ProcessParams.idr b/TTImp/ProcessParams.idr index f80d082b49..3e33958e9f 100644 --- a/TTImp/ProcessParams.idr +++ b/TTImp/ProcessParams.idr @@ -39,7 +39,7 @@ processParams {vars} {c} {m} {u} nest env fc ps ds -- then read off the environment from the elaborated type. This way -- we'll get all the implicit names we need let pty_raw = mkParamTy ps - pty_imp <- bindTypeNames fc [] (toList vars) (Elaboratable_Bind_Here fc (PI erased) pty_raw) + pty_imp <- bindTypeNames fc [] (toList vars) (Elaborable_Bind_Here fc (PI erased) pty_raw) log "declare.param" 10 $ "Checking " ++ show pty_imp u <- uniVar fc pty <- checkTerm (-1) InType [] @@ -56,9 +56,9 @@ processParams {vars} {c} {m} {u} nest env fc ps ds traverse_ (processDecl [] nestBlock env') ds where mkParamTy : List ImpParameter -> RawImp - mkParamTy [] = Elaboratable_Type_Universe fc + mkParamTy [] = Elaborable_Type_Universe fc mkParamTy (binder :: ps) - = Elaboratable_Dependent_Function_Type fc binder.rig binder.val.info (Just binder.name.val) binder.val.boundType (mkParamTy ps) + = Elaborable_Dependent_Function_Type fc binder.rig binder.val.info (Just binder.name.val) binder.val.boundType (mkParamTy ps) applyEnv : {vs : _} -> Env Term vs -> Name -> diff --git a/TTImp/ProcessRecord.idr b/TTImp/ProcessRecord.idr index 314ad2158d..c047795bed 100644 --- a/TTImp/ProcessRecord.idr +++ b/TTImp/ProcessRecord.idr @@ -25,7 +25,7 @@ import Data.String -- errors because they've been duplicated when forming the various types of the -- record constructor, getters, etc. killHole : RawImp -> RawImp -killHole (Elaboratable_Hole fc str) = Implicit fc True +killHole (Elaborable_Hole fc str) = Implicit fc True killHole t = t -- Projections are only visible if the record is public export @@ -47,7 +47,7 @@ elabRecord : {vars : _} -> (params : List ImpParameter) -> (opts : List DataOpt) -> (conName : Name) -> - List Elaboratable_Field -> + List Elaborable_Field -> Core () elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conName_in fields = do tn <- inCurrentNS tn_in @@ -94,34 +94,34 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa -- and projections jname binder = Mk [EmptyFC, erased, Just binder.name] $ {info := Implicit} binder.val - fname : Elaboratable_Field -> Name + fname : Elaborable_Field -> Name fname field = field.name.val - farg : Elaboratable_Field -> AddFC (WithRig $ WithMName (PiBindData RawImp)) + farg : Elaborable_Field -> AddFC (WithRig $ WithMName (PiBindData RawImp)) farg field = Mk [virtualiseFC field.fc, field.rig, Just field.name] field.val mkTy : List (AddFC $ WithRig $ WithMName (PiBindData RawImp)) -> RawImp -> RawImp mkTy [] ret = ret mkTy (bind :: args) ret - = Elaboratable_Dependent_Function_Type bind.fc bind.rig bind.val.info (map val bind.mName) bind.val.boundType (mkTy args ret) + = Elaborable_Dependent_Function_Type bind.fc bind.rig bind.val.info (map val bind.mName) bind.val.boundType (mkTy args ret) recTy : (tn : Name) -> -- fully qualified name of the record type (params : List ImpParameter) -> -- list of all the parameters RawImp - recTy tn params = apply (Elaboratable_Name (virtualiseFC fc) tn) (map (\binder => (binder.name.val, Elaboratable_Name EmptyFC binder.name.val, binder.val.info)) params) + recTy tn params = apply (Elaborable_Name (virtualiseFC fc) tn) (map (\binder => (binder.name.val, Elaborable_Name EmptyFC binder.name.val, binder.val.info)) params) where ||| Apply argument to list of explicit or implicit named arguments apply : RawImp -> List (Name, RawImp, PiInfo RawImp) -> RawImp apply f [] = f - apply f ((n, arg, Explicit) :: xs) = apply (Elaboratable_Apply (getFC f) f arg) xs - apply f ((n, arg, _ ) :: xs) = apply (Elaboratable_Named_Apply (getFC f) f n arg) xs + apply f ((n, arg, Explicit) :: xs) = apply (Elaborable_Apply (getFC f) f arg) xs + apply f ((n, arg, _ ) :: xs) = apply (Elaborable_Named_Apply (getFC f) f n arg) xs paramNames : List ImpParameter -> List Name paramNames params = map (.name.val) params mkDataTy : FC -> List ImpParameter -> RawImp - mkDataTy fc [] = Elaboratable_Type_Universe fc - mkDataTy fc (binder :: ps) = Elaboratable_Dependent_Function_Type fc binder.rig binder.val.info (Just binder.name.val) binder.val.boundType (mkDataTy fc ps) + mkDataTy fc [] = Elaborable_Type_Universe fc + mkDataTy fc (binder :: ps) = Elaborable_Dependent_Function_Type fc binder.rig binder.val.info (Just binder.name.val) binder.val.boundType (mkDataTy fc ps) nestDrop : Core (List (Name, Nat)) nestDrop @@ -139,13 +139,13 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa Core (List ImpParameter) -- New telescope of parameters, including missing bindings preElabAsData tn = do let fc = virtualiseFC fc - let dataTy = Elaboratable_Bind_Here fc (PI erased) !(bindTypeNames fc [] (toList vars) (mkDataTy fc params0)) + let dataTy = Elaborable_Bind_Here fc (PI erased) !(bindTypeNames fc [] (toList vars) (mkDataTy fc params0)) defs <- get Ctxt -- Create a forward declaration if none exists when (isNothing !(lookupTyExact tn (gamma defs))) $ do let dt = MkImpLater fc tn dataTy log "declare.record" 10 $ "Pre-declare record data type: \{show dt}" - processDecl [] nest env (Elaboratable_Data_Declaration fc def_vis mbtot dt) + processDecl [] nest env (Elaborable_Data_Declaration fc def_vis mbtot dt) defs <- get Ctxt Just ty <- lookupTyExact tn (gamma defs) | Nothing => throw (InternalError "Missing data type \{show tn}, despite having just declared it!") @@ -180,10 +180,10 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa SnocList (WithRig $ WithMName $ PiBindData RawImp) -> -- accumulator RawImp' KindedName -> -- quoted type (some names may have disappeared) Core (SnocList (WithRig $ WithMName $ PiBindData RawImp)) - getParameters acc (Elaboratable_Dependent_Function_Type fc rig pinfo mnm argTy retTy) + getParameters acc (Elaborable_Dependent_Function_Type fc rig pinfo mnm argTy retTy) = let clean = mapTTImp killHole . map fullName in getParameters (acc :< (Mk [rig, map NoFC mnm] (MkPiBindData (map clean pinfo) (clean argTy)))) retTy - getParameters acc (Elaboratable_Type_Universe _) = pure acc + getParameters acc (Elaborable_Type_Universe _) = pure acc getParameters acc ty = throw (InternalError "Malformed record type \{show ty}") addMissingNames : @@ -221,7 +221,7 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa !(bindTypeNames fc [] boundNames conty) let dt = MkImpData fc tn Nothing opts [con] log "declare.record" 5 $ "Record data type " ++ show dt - processDecl [] nest env (Elaboratable_Data_Declaration fc def_vis mbtot dt) + processDecl [] nest env (Elaborable_Data_Declaration fc def_vis mbtot dt) countExp : Term vs -> Nat countExp (Bind _ _ (Pi _ _ Explicit _) sc) = S (countExp sc) @@ -267,11 +267,11 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa projTy <- bindTypeNames fc [] (paramNames ++ map fname fields ++ toList vars) $ mkTy (paramTelescope params) $ - Elaboratable_Dependent_Function_Type bfc top Explicit (Just rname) (recTy tn params) ty' + Elaborable_Dependent_Function_Type bfc top Explicit (Just rname) (recTy tn params) ty' let fc' = virtualiseFC fc let mkProjClaim = \ nm => let ty = Mk [fc', MkFCVal fc' nm] projTy - in Elaboratable_Claim (MkFCVal bfc (Make_Elaboratable_Claim_Data rig isVis [Inline] ty)) + in Elaborable_Claim (MkFCVal bfc (Make_Elaborable_Claim_Data rig isVis [Inline] ty)) log "declare.record.projection.claim" 5 $ "Projection " ++ show rfNameNS ++ ": " ++ show projTy @@ -279,18 +279,18 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa -- Define the LHS and RHS let lhs_exp - = apply (Elaboratable_Name bfc con) + = apply (Elaborable_Name bfc con) (replicate done (Implicit bfc True) ++ (if imp == Explicit - then [Elaboratable_Bind_Name fc' unName] + then [Elaborable_Bind_Name fc' unName] else []) ++ (replicate (countExp sc) (Implicit bfc True))) - let lhs = Elaboratable_Apply bfc (Elaboratable_Name bfc rfNameNS) + let lhs = Elaborable_Apply bfc (Elaborable_Name bfc rfNameNS) (if imp == Explicit then lhs_exp - else Elaboratable_Named_Apply bfc lhs_exp unName - (Elaboratable_Bind_Name bfc unName)) - let rhs = Elaboratable_Name fc' unName + else Elaborable_Named_Apply bfc lhs_exp unName + (Elaborable_Bind_Name bfc unName)) + let rhs = Elaborable_Name fc' unName -- EtaExpand implicits on both sides: -- First, obtain all the implicit names in the prefix of @@ -299,7 +299,7 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa log "declare.record.projection.clause" 5 $ "Projection " ++ show lhs ++ " = " ++ show rhs processDecl [] nest env - (Elaboratable_Definition bfc rfNameNS [PatClause bfc lhs rhs]) + (Elaborable_Definition bfc rfNameNS [PatClause bfc lhs rhs]) -- Make prefix projection aliases if requested when !isPrefixRecordProjections $ do -- beware: `!` is NOT boolean `not`! @@ -310,12 +310,12 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa processDecl [] nest env (mkProjClaim unNameNS) -- Define the LHS and RHS - let lhs = Elaboratable_Name bfc unNameNS - let rhs = Elaboratable_Name bfc rfNameNS + let lhs = Elaborable_Name bfc unNameNS + let rhs = Elaborable_Name bfc rfNameNS log "declare.record.projection.prefix" 5 $ "Prefix projection " ++ show lhs ++ " = " ++ show rhs processDecl [] nest env - (Elaboratable_Definition bfc unNameNS [PatClause bfc lhs rhs]) + (Elaborable_Definition bfc unNameNS [PatClause bfc lhs rhs]) -- Move on to the next getter. -- @@ -328,8 +328,8 @@ elabRecord {vars} eopts fc env nest newns def_vis mbtot tn_in params0 opts conNa -- (though the only difference I'm aware is in the output of the `:doc` command) prefix_flag <- isPrefixRecordProjections let upds' = if prefix_flag - then (n, Elaboratable_Apply bfc (Elaboratable_Name bfc unNameNS) (Elaboratable_Name bfc rname)) :: upds - else (n, Elaboratable_Apply bfc (Elaboratable_Name bfc rfNameNS) (Elaboratable_Name bfc rname)) :: upds + then (n, Elaborable_Apply bfc (Elaborable_Name bfc unNameNS) (Elaborable_Name bfc rname)) :: upds + else (n, Elaborable_Apply bfc (Elaborable_Name bfc rfNameNS) (Elaborable_Name bfc rname)) :: upds elabGetters tn con params (if imp == Explicit diff --git a/TTImp/ProcessType.idr b/TTImp/ProcessType.idr index b1b813c67f..b1a5657f75 100644 --- a/TTImp/ProcessType.idr +++ b/TTImp/ProcessType.idr @@ -29,7 +29,7 @@ getFnString : {auto c : Ref Ctxt Defs} -> {auto s : Ref Syn SyntaxInfo} -> {auto o : Ref ROpts REPLOpts} -> RawImp -> Core String -getFnString (Elaboratable_Primitive_Value _ (Str st)) = pure st +getFnString (Elaborable_Primitive_Value _ (Str st)) = pure st getFnString tm = do inidx <- resolveName (UN $ Basic "[foreign]") let fc = getFC tm @@ -120,7 +120,7 @@ findInferrable defs ty = fi 0 0 [] NatSet.empty ty fi pos i args acc ret = findInf acc args ret checkForShadowing : (env : StringMap FC) -> RawImp -> StringMap (FC, FC) -checkForShadowing env (Elaboratable_Dependent_Function_Type fc _ _ nm argTy retTy) +checkForShadowing env (Elaborable_Dependent_Function_Type fc _ _ nm argTy retTy) = do let argShadowing = checkForShadowing empty argTy let retShadowing = case nm of @@ -162,7 +162,7 @@ processType {vars} eopts nest env fc rig vis opts ty_raw ty <- wrapErrorC eopts (InType fc n) $ checkTerm idx InType (HolesOkay :: eopts) nest env - (Elaboratable_Bind_Here fc (PI erased) ty_raw.val) + (Elaborable_Bind_Here fc (PI erased) ty_raw.val) (gType fc u) logTermNF "declare.type" 3 ("Type of " ++ show n) Env.empty (abstractFullEnvType tfc env ty) diff --git a/TTImp/Reflect.idr b/TTImp/Reflect.idr index f2d851763d..6ebe7b03d0 100644 --- a/TTImp/Reflect.idr +++ b/TTImp/Reflect.idr @@ -92,7 +92,7 @@ mutual (UN (Basic "IVar"), [fc, n]) => do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) - pure (Elaboratable_Name fc' n') + pure (Elaborable_Name fc' n') (UN (Basic "IPi"), [fc, c, p, mn, aty, rty]) => do fc' <- reify defs !(evalClosure defs fc) c' <- reify defs !(evalClosure defs c) @@ -100,7 +100,7 @@ mutual mn' <- reify defs !(evalClosure defs mn) aty' <- reify defs !(evalClosure defs aty) rty' <- reify defs !(evalClosure defs rty) - pure (Elaboratable_Dependent_Function_Type fc' c' p' mn' aty' rty') + pure (Elaborable_Dependent_Function_Type fc' c' p' mn' aty' rty') (UN (Basic "ILam"), [fc, c, p, mn, aty, lty]) => do fc' <- reify defs !(evalClosure defs fc) c' <- reify defs !(evalClosure defs c) @@ -108,7 +108,7 @@ mutual mn' <- reify defs !(evalClosure defs mn) aty' <- reify defs !(evalClosure defs aty) lty' <- reify defs !(evalClosure defs lty) - pure (Elaboratable_Lambda fc' c' p' mn' aty' lty') + pure (Elaborable_Lambda fc' c' p' mn' aty' lty') (UN (Basic "ILet"), [fc, lhsFC, c, n, ty, val, sc]) => do fc' <- reify defs !(evalClosure defs fc) lhsFC' <- reify defs !(evalClosure defs lhsFC) @@ -117,120 +117,120 @@ mutual ty' <- reify defs !(evalClosure defs ty) val' <- reify defs !(evalClosure defs val) sc' <- reify defs !(evalClosure defs sc) - pure (Elaboratable_Binding fc' lhsFC' c' n' ty' val' sc') + pure (Elaborable_Binding fc' lhsFC' c' n' ty' val' sc') (UN (Basic "ICase"), [fc, opts, sc, ty, cs]) => do fc' <- reify defs !(evalClosure defs fc) opts' <- reify defs !(evalClosure defs opts) sc' <- reify defs !(evalClosure defs sc) ty' <- reify defs !(evalClosure defs ty) cs' <- reify defs !(evalClosure defs cs) - pure (Elaboratable_Case fc' opts' sc' ty' cs') + pure (Elaborable_Case fc' opts' sc' ty' cs') (UN (Basic "ILocal"), [fc, ds, sc]) => do fc' <- reify defs !(evalClosure defs fc) ds' <- reify defs !(evalClosure defs ds) sc' <- reify defs !(evalClosure defs sc) - pure (Elaboratable_Local_Definitions fc' ds' sc') + pure (Elaborable_Local_Definitions fc' ds' sc') (UN (Basic "IUpdate"), [fc, ds, sc]) => do fc' <- reify defs !(evalClosure defs fc) ds' <- reify defs !(evalClosure defs ds) sc' <- reify defs !(evalClosure defs sc) - pure (Elaboratable_Record_Update fc' ds' sc') + pure (Elaborable_Record_Update fc' ds' sc') (UN (Basic "IApp"), [fc, f, a]) => do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) a' <- reify defs !(evalClosure defs a) - pure (Elaboratable_Apply fc' f' a') + pure (Elaborable_Apply fc' f' a') (UN (Basic "INamedApp"), [fc, f, m, a]) => do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) m' <- reify defs !(evalClosure defs m) a' <- reify defs !(evalClosure defs a) - pure (Elaboratable_Named_Apply fc' f' m' a') + pure (Elaborable_Named_Apply fc' f' m' a') (UN (Basic "IAutoApp"), [fc, f, a]) => do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) a' <- reify defs !(evalClosure defs a) - pure (Elaboratable_Automatic_Apply fc' f' a') + pure (Elaborable_Automatic_Apply fc' f' a') (UN (Basic "IWithApp"), [fc, f, a]) => do fc' <- reify defs !(evalClosure defs fc) f' <- reify defs !(evalClosure defs f) a' <- reify defs !(evalClosure defs a) - pure (Elaboratable_With_Apply fc' f' a') + pure (Elaborable_With_Apply fc' f' a') (UN (Basic "ISearch"), [fc, d]) => do fc' <- reify defs !(evalClosure defs fc) d' <- reify defs !(evalClosure defs d) - pure (Elaboratable_Search fc' d') + pure (Elaborable_Search fc' d') (UN (Basic "IAlternative"), [fc, t, as]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) as' <- reify defs !(evalClosure defs as) - pure (Elaboratable_Alternative fc' t' as') + pure (Elaborable_Alternative fc' t' as') (UN (Basic "IRewrite"), [fc, t, sc]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) sc' <- reify defs !(evalClosure defs sc) - pure (Elaboratable_Rewrite fc' t' sc') + pure (Elaborable_Rewrite fc' t' sc') (UN (Basic "IBindHere"), [fc, t, sc]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) sc' <- reify defs !(evalClosure defs sc) - pure (Elaboratable_Bind_Here fc' t' sc') + pure (Elaborable_Bind_Here fc' t' sc') (UN (Basic "IBindVar"), [fc, n]) => do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) - pure (Elaboratable_Bind_Name fc' n') + pure (Elaborable_Bind_Name fc' n') (UN (Basic "IAs"), [fc, nameFC, s, n, t]) => do fc' <- reify defs !(evalClosure defs fc) nameFC' <- reify defs !(evalClosure defs nameFC) s' <- reify defs !(evalClosure defs s) n' <- reify defs !(evalClosure defs n) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_As_Pattern fc' nameFC' s' n' t') + pure (Elaborable_As_Pattern fc' nameFC' s' n' t') (UN (Basic "IMustUnify"), [fc, r, t]) => do fc' <- reify defs !(evalClosure defs fc) r' <- reify defs !(evalClosure defs r) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_Must_Unify fc' r' t') + pure (Elaborable_Must_Unify fc' r' t') (UN (Basic "IDelayed"), [fc, r, t]) => do fc' <- reify defs !(evalClosure defs fc) r' <- reify defs !(evalClosure defs r) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_Delayed_Type fc' r' t') + pure (Elaborable_Delayed_Type fc' r' t') (UN (Basic "IDelay"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_Delay fc' t') + pure (Elaborable_Delay fc' t') (UN (Basic "IForce"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_Force fc' t') + pure (Elaborable_Force fc' t') (UN (Basic "IQuote"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_Quote fc' t') + pure (Elaborable_Quote fc' t') (UN (Basic "IQuoteName"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_Quote_Name fc' t') + pure (Elaborable_Quote_Name fc' t') (UN (Basic "IQuoteDecl"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_Quote_Declarations fc' t') + pure (Elaborable_Quote_Declarations fc' t') (UN (Basic "IUnquote"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_Unquote fc' t') + pure (Elaborable_Unquote fc' t') (UN (Basic "IPrimVal"), [fc, t]) => do fc' <- reify defs !(evalClosure defs fc) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_Primitive_Value fc' t') + pure (Elaborable_Primitive_Value fc' t') (UN (Basic "IType"), [fc]) => do fc' <- reify defs !(evalClosure defs fc) - pure (Elaboratable_Type_Universe fc') + pure (Elaborable_Type_Universe fc') (UN (Basic "IHole"), [fc, n]) => do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) - pure (Elaboratable_Hole fc' n') + pure (Elaborable_Hole fc' n') (UN (Basic "Implicit"), [fc, n]) => do fc' <- reify defs !(evalClosure defs fc) n' <- reify defs !(evalClosure defs n) @@ -239,22 +239,22 @@ mutual => do fc' <- reify defs !(evalClosure defs fc) ns' <- reify defs !(evalClosure defs ns) t' <- reify defs !(evalClosure defs t) - pure (Elaboratable_With_Unambiguous_Names fc' ns' t') + pure (Elaborable_With_Unambiguous_Names fc' ns' t') _ => cantReify val "TTImp" reify defs val = cantReify val "TTImp" export - Reify Elaboratable_Field_Update where + Reify Elaborable_Field_Update where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), args) of (UN (Basic "ISetField"), [(_, x), (_, y)]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) - pure (Elaboratable_Set_Field x' y') + pure (Elaborable_Set_Field x' y') (UN (Basic "ISetFieldApp"), [(_, x), (_, y)]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) - pure (Elaboratable_Apply_To_Field x' y') + pure (Elaborable_Apply_To_Field x' y') _ => cantReify val "IFieldUpdate" reify defs val = cantReify val "IFieldUpdate" @@ -351,7 +351,7 @@ mutual reify defs val = cantReify val "Data" export - Reify Elaboratable_Field where + Reify Elaborable_Field where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of (UN (Basic "MkIField"), [v,w,x,y,z]) @@ -415,7 +415,7 @@ mutual reify defs val = cantReify val "Clause" export - Reify (Elaboratable_Claim_Data Name) where + Reify (Elaborable_Claim_Data Name) where reify defs val@(NDCon _ n _ _ args) = case (dropAllNS !(full (gamma defs) n), map snd args) of (UN (Basic "MkIClaimData"), [w, x, y, z]) @@ -423,7 +423,7 @@ mutual x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) - pure (Make_Elaboratable_Claim_Data w' x' y' z') + pure (Make_Elaborable_Claim_Data w' x' y' z') _ => cantReify val "IClaimData" reify defs val = cantReify val "IClaimData" @@ -433,60 +433,60 @@ mutual = case (dropAllNS !(full (gamma defs) n), map snd args) of (UN (Basic "IClaim"), [v]) => do v' <- reify defs !(evalClosure defs v) - pure (Elaboratable_Claim v') + pure (Elaborable_Claim v') (UN (Basic "IData"), [x,y,z,w]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) w' <- reify defs !(evalClosure defs w) - pure (Elaboratable_Data_Declaration x' y' z' w') + pure (Elaborable_Data_Declaration x' y' z' w') (UN (Basic "IDef"), [x,y,z]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) - pure (Elaboratable_Definition x' y' z') + pure (Elaborable_Definition x' y' z') (UN (Basic "IParameters"), [x,y,z]) => do x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) - pure (Elaboratable_Parameter_Block x' (map fromOldParams y') z') + pure (Elaborable_Parameter_Block x' (map fromOldParams y') z') (UN (Basic "IRecord"), [w,x,y,z,u]) => do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) u' <- reify defs !(evalClosure defs u) - pure (Elaboratable_Record_Declaration w' x' y' z' u') + pure (Elaborable_Record_Declaration w' x' y' z' u') (UN (Basic "IFail"), [w,x,y]) => do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) - pure (Elaboratable_Expected_Failure w' x' y') + pure (Elaborable_Expected_Failure w' x' y') (UN (Basic "INamespace"), [w,x,y]) => do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) - pure (Elaboratable_Namespace_Block w' x' y') + pure (Elaborable_Namespace_Block w' x' y') (UN (Basic "ITransform"), [w,x,y,z]) => do w' <- reify defs !(evalClosure defs w) x' <- reify defs !(evalClosure defs x) y' <- reify defs !(evalClosure defs y) z' <- reify defs !(evalClosure defs z) - pure (Elaboratable_Transformation w' x' y' z') + pure (Elaborable_Transformation w' x' y' z') (UN (Basic "ILog"), [x]) => do x' <- reify defs !(evalClosure defs x) - pure (Elaboratable_Logging x') + pure (Elaborable_Logging x') _ => cantReify val "Decl" reify defs val = cantReify val "Decl" mutual export Reflect RawImp where - reflect fc defs lhs env (Elaboratable_Name tfc n) + reflect fc defs lhs env (Elaborable_Name tfc n) = do fc' <- reflect fc defs lhs env tfc n' <- reflect fc defs lhs env n appCon fc defs (reflectionttimp "IVar") [fc', n'] - reflect fc defs lhs env (Elaboratable_Dependent_Function_Type tfc c p mn aty rty) + reflect fc defs lhs env (Elaborable_Dependent_Function_Type tfc c p mn aty rty) = do fc' <- reflect fc defs lhs env tfc c' <- reflect fc defs lhs env c p' <- reflect fc defs lhs env p @@ -494,7 +494,7 @@ mutual aty' <- reflect fc defs lhs env aty rty' <- reflect fc defs lhs env rty appCon fc defs (reflectionttimp "IPi") [fc', c', p', mn', aty', rty'] - reflect fc defs lhs env (Elaboratable_Lambda tfc c p mn aty rty) + reflect fc defs lhs env (Elaborable_Lambda tfc c p mn aty rty) = do fc' <- reflect fc defs lhs env tfc c' <- reflect fc defs lhs env c p' <- reflect fc defs lhs env p @@ -502,7 +502,7 @@ mutual aty' <- reflect fc defs lhs env aty rty' <- reflect fc defs lhs env rty appCon fc defs (reflectionttimp "ILam") [fc', c', p', mn', aty', rty'] - reflect fc defs lhs env (Elaboratable_Binding tfc lhsFC c n aty aval sc) + reflect fc defs lhs env (Elaborable_Binding tfc lhsFC c n aty aval sc) = do fc' <- reflect fc defs lhs env tfc lhsFC' <- reflect fc defs lhs env lhsFC c' <- reflect fc defs lhs env c @@ -511,125 +511,125 @@ mutual aval' <- reflect fc defs lhs env aval sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "ILet") [fc', lhsFC', c', n', aty', aval', sc'] - reflect fc defs lhs env (Elaboratable_Case tfc opts sc ty cs) + reflect fc defs lhs env (Elaborable_Case tfc opts sc ty cs) = do fc' <- reflect fc defs lhs env tfc opts' <- reflect fc defs lhs env opts sc' <- reflect fc defs lhs env sc ty' <- reflect fc defs lhs env ty cs' <- reflect fc defs lhs env cs appCon fc defs (reflectionttimp "ICase") [fc', opts', sc', ty', cs'] - reflect fc defs lhs env (Elaboratable_Local_Definitions tfc ds sc) + reflect fc defs lhs env (Elaborable_Local_Definitions tfc ds sc) = do fc' <- reflect fc defs lhs env tfc ds' <- reflect fc defs lhs env ds sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "ILocal") [fc', ds', sc'] - reflect fc defs lhs env (Elaboratable_Case_Local_Definition tfc u i args t) + reflect fc defs lhs env (Elaborable_Case_Local_Definition tfc u i args t) = reflect fc defs lhs env t -- shouldn't see this anyway... - reflect fc defs lhs env (Elaboratable_Record_Update tfc ds sc) + reflect fc defs lhs env (Elaborable_Record_Update tfc ds sc) = do fc' <- reflect fc defs lhs env tfc ds' <- reflect fc defs lhs env ds sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "IUpdate") [fc', ds', sc'] - reflect fc defs lhs env (Elaboratable_Apply tfc f a) + reflect fc defs lhs env (Elaborable_Apply tfc f a) = do fc' <- reflect fc defs lhs env tfc f' <- reflect fc defs lhs env f a' <- reflect fc defs lhs env a appCon fc defs (reflectionttimp "IApp") [fc', f', a'] - reflect fc defs lhs env (Elaboratable_Automatic_Apply tfc f a) + reflect fc defs lhs env (Elaborable_Automatic_Apply tfc f a) = do fc' <- reflect fc defs lhs env tfc f' <- reflect fc defs lhs env f a' <- reflect fc defs lhs env a appCon fc defs (reflectionttimp "IAutoApp") [fc', f', a'] - reflect fc defs lhs env (Elaboratable_Named_Apply tfc f m a) + reflect fc defs lhs env (Elaborable_Named_Apply tfc f m a) = do fc' <- reflect fc defs lhs env tfc f' <- reflect fc defs lhs env f m' <- reflect fc defs lhs env m a' <- reflect fc defs lhs env a appCon fc defs (reflectionttimp "INamedApp") [fc', f', m', a'] - reflect fc defs lhs env (Elaboratable_With_Apply tfc f a) + reflect fc defs lhs env (Elaborable_With_Apply tfc f a) = do fc' <- reflect fc defs lhs env tfc f' <- reflect fc defs lhs env f a' <- reflect fc defs lhs env a appCon fc defs (reflectionttimp "IWithApp") [fc', f', a'] - reflect fc defs lhs env (Elaboratable_Search tfc d) + reflect fc defs lhs env (Elaborable_Search tfc d) = do fc' <- reflect fc defs lhs env tfc d' <- reflect fc defs lhs env d appCon fc defs (reflectionttimp "ISearch") [fc', d'] - reflect fc defs lhs env (Elaboratable_Alternative tfc t as) + reflect fc defs lhs env (Elaborable_Alternative tfc t as) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t as' <- reflect fc defs lhs env as appCon fc defs (reflectionttimp "IAlternative") [fc', t', as'] - reflect fc defs lhs env (Elaboratable_Rewrite tfc t sc) + reflect fc defs lhs env (Elaborable_Rewrite tfc t sc) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "IRewrite") [fc', t', sc'] - reflect fc defs lhs env (Elaboratable_Coerced tfc d) = reflect fc defs lhs env d - reflect fc defs lhs env (Elaboratable_Bind_Here tfc n sc) + reflect fc defs lhs env (Elaborable_Coerced tfc d) = reflect fc defs lhs env d + reflect fc defs lhs env (Elaborable_Bind_Here tfc n sc) = do fc' <- reflect fc defs lhs env tfc n' <- reflect fc defs lhs env n sc' <- reflect fc defs lhs env sc appCon fc defs (reflectionttimp "IBindHere") [fc', n', sc'] - reflect fc defs lhs env (Elaboratable_Bind_Name tfc n) + reflect fc defs lhs env (Elaborable_Bind_Name tfc n) = do fc' <- reflect fc defs lhs env tfc n' <- reflect fc defs lhs env n appCon fc defs (reflectionttimp "IBindVar") [fc', n'] - reflect fc defs lhs env (Elaboratable_As_Pattern tfc nameFC s n t) + reflect fc defs lhs env (Elaborable_As_Pattern tfc nameFC s n t) = do fc' <- reflect fc defs lhs env tfc nameFC' <- reflect fc defs lhs env nameFC s' <- reflect fc defs lhs env s n' <- reflect fc defs lhs env n t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IAs") [fc', nameFC', s', n', t'] - reflect fc defs lhs env (Elaboratable_Must_Unify tfc r t) + reflect fc defs lhs env (Elaborable_Must_Unify tfc r t) = do fc' <- reflect fc defs lhs env tfc r' <- reflect fc defs lhs env r t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IMustUnify") [fc', r', t'] - reflect fc defs lhs env (Elaboratable_Delayed_Type tfc r t) + reflect fc defs lhs env (Elaborable_Delayed_Type tfc r t) = do fc' <- reflect fc defs lhs env tfc r' <- reflect fc defs lhs env r t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IDelayed") [fc', r', t'] - reflect fc defs lhs env (Elaboratable_Delay tfc t) + reflect fc defs lhs env (Elaborable_Delay tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IDelay") [fc', t'] - reflect fc defs lhs env (Elaboratable_Force tfc t) + reflect fc defs lhs env (Elaborable_Force tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IForce") [fc', t'] - reflect fc defs lhs env (Elaboratable_Quote tfc t) + reflect fc defs lhs env (Elaborable_Quote tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IQuote") [fc', t'] - reflect fc defs lhs env (Elaboratable_Quote_Name tfc t) + reflect fc defs lhs env (Elaborable_Quote_Name tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IQuoteName") [fc', t'] - reflect fc defs lhs env (Elaboratable_Quote_Declarations tfc t) + reflect fc defs lhs env (Elaborable_Quote_Declarations tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IQuoteDecl") [fc', t'] - reflect fc defs lhs env (Elaboratable_Unquote tfc (Elaboratable_Name _ t)) + reflect fc defs lhs env (Elaborable_Unquote tfc (Elaborable_Name _ t)) = pure (Ref tfc Bound t) - reflect fc defs lhs env (Elaboratable_Unquote tfc t) + reflect fc defs lhs env (Elaborable_Unquote tfc t) = throw (InternalError "Can't reflect an unquote: escapes should be lifted out") - reflect fc defs lhs env (Elaboratable_Run_Elaborator tfc _ t) + reflect fc defs lhs env (Elaborable_Run_Elaborator tfc _ t) = throw (InternalError "Can't reflect a %runElab") - reflect fc defs lhs env (Elaboratable_Primitive_Value tfc t) + reflect fc defs lhs env (Elaborable_Primitive_Value tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IPrimVal") [fc', t'] - reflect fc defs lhs env (Elaboratable_Type_Universe tfc) + reflect fc defs lhs env (Elaborable_Type_Universe tfc) = do fc' <- reflect fc defs lhs env tfc appCon fc defs (reflectionttimp "IType") [fc'] - reflect fc defs lhs env (Elaboratable_Hole tfc t) + reflect fc defs lhs env (Elaborable_Hole tfc t) = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IHole") [fc', t'] - reflect fc defs lhs env (Elaboratable_Unification_Log tfc _ t) + reflect fc defs lhs env (Elaborable_Unification_Log tfc _ t) = reflect fc defs lhs env t reflect fc defs True env (Implicit tfc t) = pure (Erased fc Placeholder) @@ -637,19 +637,19 @@ mutual = do fc' <- reflect fc defs lhs env tfc t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "Implicit") [fc', t'] - reflect fc defs lhs env (Elaboratable_With_Unambiguous_Names tfc ns t) + reflect fc defs lhs env (Elaborable_With_Unambiguous_Names tfc ns t) = do fc' <- reflect fc defs lhs env tfc ns' <- reflect fc defs lhs env ns t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "IWithUnambigNames") [fc', ns', t'] export - Reflect Elaboratable_Field_Update where - reflect fc defs lhs env (Elaboratable_Set_Field p t) + Reflect Elaborable_Field_Update where + reflect fc defs lhs env (Elaborable_Set_Field p t) = do p' <- reflect fc defs lhs env p t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "ISetField") [p', t'] - reflect fc defs lhs env (Elaboratable_Apply_To_Field p t) + reflect fc defs lhs env (Elaborable_Apply_To_Field p t) = do p' <- reflect fc defs lhs env p t' <- reflect fc defs lhs env t appCon fc defs (reflectionttimp "ISetFieldApp") [p', t'] @@ -725,7 +725,7 @@ mutual appCon fc defs (reflectionttimp "MkLater") [x', y', z'] export - Reflect Elaboratable_Field where + Reflect Elaborable_Field where reflect fc defs lhs env field -- Order matters to maintain compatibility with elab reflection = do v' <- reflect fc defs lhs env field.fc w' <- reflect fc defs lhs env field.rig @@ -771,8 +771,8 @@ mutual appCon fc defs (reflectionttimp "ImpossibleClause") [x', y'] export - Reflect (Elaboratable_Claim_Data Name) where - reflect fc defs lhs env (Make_Elaboratable_Claim_Data w x y z) + Reflect (Elaborable_Claim_Data Name) where + reflect fc defs lhs env (Make_Elaborable_Claim_Data w x y z) = do w' <- reflect fc defs lhs env w x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y @@ -781,54 +781,54 @@ mutual export Reflect ImpDecl where - reflect fc defs lhs env (Elaboratable_Claim v) + reflect fc defs lhs env (Elaborable_Claim v) = do v' <- reflect fc defs lhs env v appCon fc defs (reflectionttimp "IClaim") [v'] - reflect fc defs lhs env (Elaboratable_Data_Declaration x y z w) + reflect fc defs lhs env (Elaborable_Data_Declaration x y z w) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z w' <- reflect fc defs lhs env w appCon fc defs (reflectionttimp "IData") [x', y', z', w'] - reflect fc defs lhs env (Elaboratable_Definition x y z) + reflect fc defs lhs env (Elaborable_Definition x y z) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "IDef") [x', y', z'] - reflect fc defs lhs env (Elaboratable_Parameter_Block x y z) + reflect fc defs lhs env (Elaborable_Parameter_Block x y z) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env (map toOldParams y) z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "IParameters") [x', y', z'] - reflect fc defs lhs env (Elaboratable_Record_Declaration w x y z u) + reflect fc defs lhs env (Elaborable_Record_Declaration w x y z u) = do w' <- reflect fc defs lhs env w x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z u' <- reflect fc defs lhs env u appCon fc defs (reflectionttimp "IRecord") [w', x', y', z', u'] - reflect fc defs lhs env (Elaboratable_Expected_Failure x y z) + reflect fc defs lhs env (Elaborable_Expected_Failure x y z) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "IFail") [x', y', z'] - reflect fc defs lhs env (Elaboratable_Namespace_Block x y z) + reflect fc defs lhs env (Elaborable_Namespace_Block x y z) = do x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "INamespace") [x', y', z'] - reflect fc defs lhs env (Elaboratable_Transformation w x y z) + reflect fc defs lhs env (Elaborable_Transformation w x y z) = do w' <- reflect fc defs lhs env w x' <- reflect fc defs lhs env x y' <- reflect fc defs lhs env y z' <- reflect fc defs lhs env z appCon fc defs (reflectionttimp "ITransform") [w', x', y', z'] - reflect fc defs lhs env (Elaboratable_Run_Elaborator_Declaration w x) + reflect fc defs lhs env (Elaborable_Run_Elaborator_Declaration w x) = throw (GenericMsg fc "Can't reflect a %runElab") - reflect fc defs lhs env (Elaboratable_Pragma _ _ x) + reflect fc defs lhs env (Elaborable_Pragma _ _ x) = throw (GenericMsg fc "Can't reflect a pragma") - reflect fc defs lhs env (Elaboratable_Logging x) + reflect fc defs lhs env (Elaborable_Logging x) = do x' <- reflect fc defs lhs env x appCon fc defs (reflectionttimp "ILog") [x'] - reflect fc defs lhs env (Elaboratable_Builtin_Declaration {}) + reflect fc defs lhs env (Elaborable_Builtin_Declaration {}) = throw (GenericMsg fc "Can't reflect a %builtin") diff --git a/TTImp/TTImp.idr b/TTImp/TTImp.idr index 3cefcf3312..434bd8aa4b 100644 --- a/TTImp/TTImp.idr +++ b/TTImp/TTImp.idr @@ -42,7 +42,7 @@ mapNestedName nest n = case lookup n (names nest) of _ => n -- Unchecked terms, with implicit arguments --- This is the raw, elaboratable form. +-- This is the raw, elaborable form. -- Higher level expressions (e.g. case, pattern matching let, where blocks, -- do notation, etc, should elaborate via this, perhaps in some local -- context). @@ -58,89 +58,89 @@ mutual RawImp = RawImp' Name public export - Kinded_Elaboratable_Term : Type - Kinded_Elaboratable_Term = RawImp' KindedName + Kinded_Elaborable_Term : Type + Kinded_Elaborable_Term = RawImp' KindedName public export data RawImp' : Type -> Type where - Elaboratable_Name : FC -> nm -> RawImp' nm - Elaboratable_Dependent_Function_Type : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> + Elaborable_Name : FC -> nm -> RawImp' nm + Elaborable_Dependent_Function_Type : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> (argTy : RawImp' nm) -> (retTy : RawImp' nm) -> RawImp' nm - Elaboratable_Lambda : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> + Elaborable_Lambda : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> (argTy : RawImp' nm) -> (lamTy : RawImp' nm) -> RawImp' nm - Elaboratable_Binding : FC -> (lhsFC : FC) -> RigCount -> Name -> + Elaborable_Binding : FC -> (lhsFC : FC) -> RigCount -> Name -> (nTy : RawImp' nm) -> (nVal : RawImp' nm) -> (scope : RawImp' nm) -> RawImp' nm - Elaboratable_Case : FC -> List (FnOpt' nm) -> RawImp' nm -> (ty : RawImp' nm) -> + Elaborable_Case : FC -> List (FnOpt' nm) -> RawImp' nm -> (ty : RawImp' nm) -> List (ImpClause' nm) -> RawImp' nm - Elaboratable_Local_Definitions : FC -> List (ImpDecl' nm) -> RawImp' nm -> RawImp' nm + Elaborable_Local_Definitions : FC -> List (ImpDecl' nm) -> RawImp' nm -> RawImp' nm -- Local definitions made elsewhere, but that we're pushing -- into a case branch as nested names. -- An appearance of 'uname' maps to an application of -- 'internalName' to 'args'. - Elaboratable_Case_Local_Definition : FC -> (uname : Name) -> + Elaborable_Case_Local_Definition : FC -> (uname : Name) -> (internalName : Name) -> (args : List Name) -> RawImp' nm -> RawImp' nm - Elaboratable_Record_Update : FC -> List (Elaboratable_Field_Update' nm) -> RawImp' nm -> RawImp' nm + Elaborable_Record_Update : FC -> List (Elaborable_Field_Update' nm) -> RawImp' nm -> RawImp' nm - Elaboratable_Apply : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm - Elaboratable_Automatic_Apply : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm - Elaboratable_Named_Apply : FC -> RawImp' nm -> Name -> RawImp' nm -> RawImp' nm - Elaboratable_With_Apply : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm + Elaborable_Apply : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm + Elaborable_Automatic_Apply : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm + Elaborable_Named_Apply : FC -> RawImp' nm -> Name -> RawImp' nm -> RawImp' nm + Elaborable_With_Apply : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm - Elaboratable_Search : FC -> (depth : Nat) -> RawImp' nm - Elaboratable_Alternative : FC -> AltType' nm -> List (RawImp' nm) -> RawImp' nm - Elaboratable_Rewrite : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm - Elaboratable_Coerced : FC -> RawImp' nm -> RawImp' nm + Elaborable_Search : FC -> (depth : Nat) -> RawImp' nm + Elaborable_Alternative : FC -> AltType' nm -> List (RawImp' nm) -> RawImp' nm + Elaborable_Rewrite : FC -> RawImp' nm -> RawImp' nm -> RawImp' nm + Elaborable_Coerced : FC -> RawImp' nm -> RawImp' nm -- Any implicit bindings in the scope should be bound here, using -- the given binder - Elaboratable_Bind_Here : FC -> BindMode -> RawImp' nm -> RawImp' nm + Elaborable_Bind_Here : FC -> BindMode -> RawImp' nm -> RawImp' nm -- A name which should be implicitly bound - Elaboratable_Bind_Name : FC -> Name -> RawImp' nm + Elaborable_Bind_Name : FC -> Name -> RawImp' nm -- An 'as' pattern, valid on the LHS of a clause only - Elaboratable_As_Pattern : FC -> (nameFC : FC) -> UseSide -> Name -> RawImp' nm -> RawImp' nm + Elaborable_As_Pattern : FC -> (nameFC : FC) -> UseSide -> Name -> RawImp' nm -> RawImp' nm -- A 'dot' pattern, i.e. one which must also have the given value -- by unification - Elaboratable_Must_Unify : FC -> DotReason -> RawImp' nm -> RawImp' nm + Elaborable_Must_Unify : FC -> DotReason -> RawImp' nm -> RawImp' nm -- Laziness annotations - Elaboratable_Delayed_Type : FC -> LazyReason -> RawImp' nm -> RawImp' nm -- the type - Elaboratable_Delay : FC -> RawImp' nm -> RawImp' nm -- delay constructor - Elaboratable_Force : FC -> RawImp' nm -> RawImp' nm + Elaborable_Delayed_Type : FC -> LazyReason -> RawImp' nm -> RawImp' nm -- the type + Elaborable_Delay : FC -> RawImp' nm -> RawImp' nm -- delay constructor + Elaborable_Force : FC -> RawImp' nm -> RawImp' nm -- Quasiquoting - Elaboratable_Quote : FC -> RawImp' nm -> RawImp' nm - Elaboratable_Quote_Name : FC -> Name -> RawImp' nm - Elaboratable_Quote_Declarations : FC -> List (ImpDecl' nm) -> RawImp' nm - Elaboratable_Unquote : FC -> RawImp' nm -> RawImp' nm - Elaboratable_Run_Elaborator : FC -> (requireExtension : Bool) -> RawImp' nm -> RawImp' nm + Elaborable_Quote : FC -> RawImp' nm -> RawImp' nm + Elaborable_Quote_Name : FC -> Name -> RawImp' nm + Elaborable_Quote_Declarations : FC -> List (ImpDecl' nm) -> RawImp' nm + Elaborable_Unquote : FC -> RawImp' nm -> RawImp' nm + Elaborable_Run_Elaborator : FC -> (requireExtension : Bool) -> RawImp' nm -> RawImp' nm - Elaboratable_Primitive_Value : FC -> (c : Constant) -> RawImp' nm - Elaboratable_Type_Universe : FC -> RawImp' nm - Elaboratable_Hole : FC -> String -> RawImp' nm + Elaborable_Primitive_Value : FC -> (c : Constant) -> RawImp' nm + Elaborable_Type_Universe : FC -> RawImp' nm + Elaborable_Hole : FC -> String -> RawImp' nm - Elaboratable_Unification_Log : FC -> LogLevel -> RawImp' nm -> RawImp' nm + Elaborable_Unification_Log : FC -> LogLevel -> RawImp' nm -> RawImp' nm -- An implicit value, solved by unification, but which will also be -- bound (either as a pattern variable or a type variable) if unsolved -- at the end of elaborator Implicit : FC -> (bindIfUnsolved : Bool) -> RawImp' nm -- with-disambiguation - Elaboratable_With_Unambiguous_Names : FC -> List (FC, Name) -> RawImp' nm -> RawImp' nm + Elaborable_With_Unambiguous_Names : FC -> List (FC, Name) -> RawImp' nm -> RawImp' nm %name RawImp' t, u public export - Elaboratable_Field_Update : Type - Elaboratable_Field_Update = Elaboratable_Field_Update' Name + Elaborable_Field_Update : Type + Elaborable_Field_Update = Elaborable_Field_Update' Name public export - data Elaboratable_Field_Update' : Type -> Type where - Elaboratable_Set_Field : (path : List String) -> RawImp' nm -> Elaboratable_Field_Update' nm - Elaboratable_Apply_To_Field : (path : List String) -> RawImp' nm -> Elaboratable_Field_Update' nm - %name Elaboratable_Field_Update' upd + data Elaborable_Field_Update' : Type -> Type where + Elaborable_Set_Field : (path : List String) -> RawImp' nm -> Elaborable_Field_Update' nm + Elaborable_Apply_To_Field : (path : List String) -> RawImp' nm -> Elaborable_Field_Update' nm + %name Elaborable_Field_Update' upd public export AltType : Type @@ -156,67 +156,67 @@ mutual export covering Show nm => Show (RawImp' nm) where - show (Elaboratable_Name fc n) = show n - show (Elaboratable_Dependent_Function_Type fc c p n arg ret) + show (Elaborable_Name fc n) = show n + show (Elaborable_Dependent_Function_Type fc c p n arg ret) = "(%pi " ++ show c ++ " " ++ show p ++ " " ++ showPrec App n ++ " " ++ show arg ++ " " ++ show ret ++ ")" - show (Elaboratable_Lambda fc c p n arg sc) + show (Elaborable_Lambda fc c p n arg sc) = "(%lam " ++ show c ++ " " ++ show p ++ " " ++ showPrec App n ++ " " ++ show arg ++ " " ++ show sc ++ ")" - show (Elaboratable_Binding fc lhsFC c n ty val sc) + show (Elaborable_Binding fc lhsFC c n ty val sc) = "(%let " ++ show c ++ " " ++ " " ++ show n ++ " " ++ show ty ++ " " ++ show val ++ " " ++ show sc ++ ")" - show (Elaboratable_Case _ _ scr scrty alts) + show (Elaborable_Case _ _ scr scrty alts) = "(%case (" ++ show scr ++ " : " ++ show scrty ++ ") " ++ show alts ++ ")" - show (Elaboratable_Local_Definitions _ def scope) + show (Elaborable_Local_Definitions _ def scope) = "(%local (" ++ show def ++ ") " ++ show scope ++ ")" - show (Elaboratable_Case_Local_Definition _ uname iname args sc) + show (Elaborable_Case_Local_Definition _ uname iname args sc) = "(%caselocal (" ++ show uname ++ " " ++ show iname ++ " " ++ show args ++ ") " ++ show sc ++ ")" - show (Elaboratable_Record_Update _ flds rec) + show (Elaborable_Record_Update _ flds rec) = "(%record " ++ showSep ", " (map show flds) ++ " " ++ show rec ++ ")" - show (Elaboratable_Apply fc f a) + show (Elaborable_Apply fc f a) = "(" ++ show f ++ " " ++ show a ++ ")" - show (Elaboratable_Named_Apply fc f n a) + show (Elaborable_Named_Apply fc f n a) = "(" ++ show f ++ " [" ++ show n ++ " = " ++ show a ++ "])" - show (Elaboratable_Automatic_Apply fc f a) + show (Elaborable_Automatic_Apply fc f a) = "(" ++ show f ++ " [" ++ show a ++ "])" - show (Elaboratable_With_Apply fc f a) + show (Elaborable_With_Apply fc f a) = "(" ++ show f ++ " | " ++ show a ++ ")" - show (Elaboratable_Search fc d) + show (Elaborable_Search fc d) = "%search" - show (Elaboratable_Alternative fc ty alts) + show (Elaborable_Alternative fc ty alts) = "(|" ++ showSep "," (map show alts) ++ "|)" - show (Elaboratable_Rewrite _ rule tm) + show (Elaborable_Rewrite _ rule tm) = "(%rewrite (" ++ show rule ++ ") (" ++ show tm ++ "))" - show (Elaboratable_Coerced _ tm) = "(%coerced " ++ show tm ++ ")" + show (Elaborable_Coerced _ tm) = "(%coerced " ++ show tm ++ ")" - show (Elaboratable_Bind_Here fc b sc) + show (Elaborable_Bind_Here fc b sc) = "(%bindhere " ++ show sc ++ ")" - show (Elaboratable_Bind_Name fc n) = "$" ++ show n - show (Elaboratable_As_Pattern fc _ _ n tm) = show n ++ "@(" ++ show tm ++ ")" - show (Elaboratable_Must_Unify fc r tm) = ".(" ++ show tm ++ ")" - show (Elaboratable_Delayed_Type fc r tm) = "(%delayed " ++ show tm ++ ")" - show (Elaboratable_Delay fc tm) = "(%delay " ++ show tm ++ ")" - show (Elaboratable_Force fc tm) = "(%force " ++ show tm ++ ")" - show (Elaboratable_Quote fc tm) = "(%quote " ++ show tm ++ ")" - show (Elaboratable_Quote_Name fc tm) = "(%quotename " ++ show tm ++ ")" - show (Elaboratable_Quote_Declarations fc tm) = "(%quotedecl " ++ show tm ++ ")" - show (Elaboratable_Unquote fc tm) = "(%unquote " ++ show tm ++ ")" - show (Elaboratable_Run_Elaborator fc _ tm) = "(%runelab " ++ show tm ++ ")" - show (Elaboratable_Primitive_Value fc c) = show c - show (Elaboratable_Hole _ x) = "?" ++ x - show (Elaboratable_Unification_Log _ lvl x) = "(%logging " ++ show lvl ++ " " ++ show x ++ ")" - show (Elaboratable_Type_Universe fc) = "%type" + show (Elaborable_Bind_Name fc n) = "$" ++ show n + show (Elaborable_As_Pattern fc _ _ n tm) = show n ++ "@(" ++ show tm ++ ")" + show (Elaborable_Must_Unify fc r tm) = ".(" ++ show tm ++ ")" + show (Elaborable_Delayed_Type fc r tm) = "(%delayed " ++ show tm ++ ")" + show (Elaborable_Delay fc tm) = "(%delay " ++ show tm ++ ")" + show (Elaborable_Force fc tm) = "(%force " ++ show tm ++ ")" + show (Elaborable_Quote fc tm) = "(%quote " ++ show tm ++ ")" + show (Elaborable_Quote_Name fc tm) = "(%quotename " ++ show tm ++ ")" + show (Elaborable_Quote_Declarations fc tm) = "(%quotedecl " ++ show tm ++ ")" + show (Elaborable_Unquote fc tm) = "(%unquote " ++ show tm ++ ")" + show (Elaborable_Run_Elaborator fc _ tm) = "(%runelab " ++ show tm ++ ")" + show (Elaborable_Primitive_Value fc c) = show c + show (Elaborable_Hole _ x) = "?" ++ x + show (Elaborable_Unification_Log _ lvl x) = "(%logging " ++ show lvl ++ " " ++ show x ++ ")" + show (Elaborable_Type_Universe fc) = "%type" show (Implicit fc True) = "_" show (Implicit fc False) = "?" - show (Elaboratable_With_Unambiguous_Names fc ns rhs) = "(%with " ++ show ns ++ " " ++ show rhs ++ ")" + show (Elaborable_With_Unambiguous_Names fc ns rhs) = "(%with " ++ show ns ++ " " ++ show rhs ++ ")" export covering - Show nm => Show (Elaboratable_Field_Update' nm) where - show (Elaboratable_Set_Field p val) = showSep "->" p ++ " = " ++ show val - show (Elaboratable_Apply_To_Field p val) = showSep "->" p ++ " $= " ++ show val + Show nm => Show (Elaborable_Field_Update' nm) where + show (Elaborable_Set_Field p val) = showSep "->" p ++ " = " ++ show val + show (Elaborable_Apply_To_Field p val) = showSep "->" p ++ " $= " ++ show val public export FnOpt : Type @@ -338,12 +338,12 @@ mutual = "(%datadecl " ++ show n ++ " " ++ show tycon ++ ")" public export - Elaboratable_Field : Type - Elaboratable_Field = Elaboratable_Field' Name + Elaborable_Field : Type + Elaborable_Field = Elaborable_Field' Name public export - Elaboratable_Field' : Type -> Type - Elaboratable_Field' nm = AddFC $ ImpParameter' (RawImp' nm) + Elaborable_Field' : Type -> Type + Elaborable_Field' nm = AddFC $ ImpParameter' (RawImp' nm) public export ImpParameter : Type @@ -380,7 +380,7 @@ mutual public export 0 RecordBody : Type -> Type -- The name is the data constructor's name - RecordBody nm = WithName $ WithOpts $ List (Elaboratable_Field' nm) + RecordBody nm = WithName $ WithOpts $ List (Elaborable_Field' nm) ||| A record is defined by its header containing the name and parameters, and its body ||| containing the constructor name, options, and a list of fields @@ -392,7 +392,7 @@ mutual export covering - Show nm => Show (Elaboratable_Field' nm) where + Show nm => Show (Elaborable_Field' nm) where show f@(MkWithData _ (MkPiBindData Explicit ty)) = show f.name.val ++ " : " ++ show ty show f@(MkWithData _ ty) = "{" ++ show f.name.val ++ " : " ++ show ty.boundType ++ "}" @@ -417,8 +417,8 @@ mutual ImpClause = ImpClause' Name public export - Kinded_Elaboratable_Clause : Type - Kinded_Elaboratable_Clause = ImpClause' KindedName + Kinded_Elaborable_Clause : Type + Kinded_Elaborable_Clause = ImpClause' KindedName public export data ImpClause' : Type -> Type where @@ -451,8 +451,8 @@ mutual ImpDecl = ImpDecl' Name public export - record Elaboratable_Claim_Data (nm : Type) where - constructor Make_Elaboratable_Claim_Data + record Elaborable_Claim_Data (nm : Type) where + constructor Make_Elaborable_Claim_Data rig : RigCount vis : Visibility opts : List (FnOpt' nm) @@ -460,60 +460,60 @@ mutual public export data ImpDecl' : Type -> Type where - Elaboratable_Claim : WithFC (Elaboratable_Claim_Data nm) -> ImpDecl' nm - Elaboratable_Data_Declaration : FC -> WithDefault Visibility Private -> + Elaborable_Claim : WithFC (Elaborable_Claim_Data nm) -> ImpDecl' nm + Elaborable_Data_Declaration : FC -> WithDefault Visibility Private -> Maybe TotalReq -> ImpData' nm -> ImpDecl' nm - Elaboratable_Definition : FC -> Name -> List (ImpClause' nm) -> ImpDecl' nm - Elaboratable_Parameter_Block : FC -> + Elaborable_Definition : FC -> Name -> List (ImpClause' nm) -> ImpDecl' nm + Elaborable_Parameter_Block : FC -> List1 (ImpParameter' (RawImp' nm)) -> List (ImpDecl' nm) -> ImpDecl' nm - Elaboratable_Record_Declaration : FC -> + Elaborable_Record_Declaration : FC -> Maybe String -> -- nested namespace WithDefault Visibility Private -> Maybe TotalReq -> AddFC (ImpRecordData nm) -> ImpDecl' nm - Elaboratable_Expected_Failure : FC -> Maybe String -> List (ImpDecl' nm) -> ImpDecl' nm - Elaboratable_Namespace_Block : FC -> Namespace -> List (ImpDecl' nm) -> ImpDecl' nm - Elaboratable_Transformation : FC -> Name -> RawImp' nm -> RawImp' nm -> ImpDecl' nm - Elaboratable_Run_Elaborator_Declaration : FC -> RawImp' nm -> ImpDecl' nm - Elaboratable_Pragma : FC -> List Name -> -- pragmas might define names that wouldn't + Elaborable_Expected_Failure : FC -> Maybe String -> List (ImpDecl' nm) -> ImpDecl' nm + Elaborable_Namespace_Block : FC -> Namespace -> List (ImpDecl' nm) -> ImpDecl' nm + Elaborable_Transformation : FC -> Name -> RawImp' nm -> RawImp' nm -> ImpDecl' nm + Elaborable_Run_Elaborator_Declaration : FC -> RawImp' nm -> ImpDecl' nm + Elaborable_Pragma : FC -> List Name -> -- pragmas might define names that wouldn't -- otherwise be spotted in 'definedInBlock' so they -- can be flagged here. ({vars : _} -> NestedNames vars -> Env Term vars -> Core ()) -> ImpDecl' nm - Elaboratable_Logging : Maybe (List String, Nat) -> ImpDecl' nm - Elaboratable_Builtin_Declaration : FC -> BuiltinType -> Name -> ImpDecl' nm + Elaborable_Logging : Maybe (List String, Nat) -> ImpDecl' nm + Elaborable_Builtin_Declaration : FC -> BuiltinType -> Name -> ImpDecl' nm %name ImpDecl' decl export covering Show nm => Show (ImpDecl' nm) where - show (Elaboratable_Claim (MkWithData _ $ Make_Elaboratable_Claim_Data c _ opts ty)) + show (Elaborable_Claim (MkWithData _ $ Make_Elaborable_Claim_Data c _ opts ty)) = show opts ++ " " ++ show c ++ " " ++ show ty - show (Elaboratable_Data_Declaration _ _ _ d) = show d - show (Elaboratable_Definition _ n cs) = "(%def " ++ show n ++ " " ++ show cs ++ ")" - show (Elaboratable_Parameter_Block _ ps ds) + show (Elaborable_Data_Declaration _ _ _ d) = show d + show (Elaborable_Definition _ n cs) = "(%def " ++ show n ++ " " ++ show cs ++ ")" + show (Elaborable_Parameter_Block _ ps ds) = "parameters " ++ show ps ++ "\n\t" ++ showSep "\n\t" (assert_total $ map show ds) - show (Elaboratable_Record_Declaration _ _ _ _ d) = show d.val - show (Elaboratable_Expected_Failure _ msg decls) + show (Elaborable_Record_Declaration _ _ _ _ d) = show d.val + show (Elaborable_Expected_Failure _ msg decls) = "fail" ++ maybe "" ((" " ++) . show) msg ++ "\n" ++ showSep "\n" (assert_total $ map ((" " ++) . show) decls) - show (Elaboratable_Namespace_Block _ ns decls) + show (Elaborable_Namespace_Block _ ns decls) = "namespace " ++ show ns ++ showSep "\n" (assert_total $ map show decls) - show (Elaboratable_Transformation _ n lhs rhs) + show (Elaborable_Transformation _ n lhs rhs) = "%transform " ++ show n ++ " " ++ show lhs ++ " ==> " ++ show rhs - show (Elaboratable_Run_Elaborator_Declaration _ tm) + show (Elaborable_Run_Elaborator_Declaration _ tm) = "%runElab " ++ show tm - show (Elaboratable_Pragma {}) = "[externally defined pragma]" - show (Elaboratable_Logging Nothing) = "%logging off" - show (Elaboratable_Logging (Just (topic, lvl))) = "%logging " ++ case topic of + show (Elaborable_Pragma {}) = "[externally defined pragma]" + show (Elaborable_Logging Nothing) = "%logging off" + show (Elaborable_Logging (Just (topic, lvl))) = "%logging " ++ case topic of [] => show lvl _ => concat (intersperse "." topic) ++ " " ++ show lvl - show (Elaboratable_Builtin_Declaration _ type name) = "%builtin " ++ show type ++ " " ++ show name + show (Elaborable_Builtin_Declaration _ type name) = "%builtin " ++ show type ++ " " ++ show name export @@ -525,30 +525,30 @@ mkWithClause fc lhs ((rig, wval, prf) ::: wp :: wps) flags cls = let vfc = virtualiseFC fc arg = UN $ Basic "arg" in WithClause fc lhs rig wval prf flags - [mkWithClause fc (Elaboratable_Apply vfc lhs $ Elaboratable_Bind_Name vfc arg) (wp ::: wps) flags cls] + [mkWithClause fc (Elaborable_Apply vfc lhs $ Elaborable_Bind_Name vfc arg) (wp ::: wps) flags cls] -- Extract the RawImp term from a FieldUpdate. export -getFieldUpdateTerm : Elaboratable_Field_Update' nm -> RawImp' nm -getFieldUpdateTerm (Elaboratable_Set_Field _ term) = term -getFieldUpdateTerm (Elaboratable_Apply_To_Field _ term) = term +getFieldUpdateTerm : Elaborable_Field_Update' nm -> RawImp' nm +getFieldUpdateTerm (Elaborable_Set_Field _ term) = term +getFieldUpdateTerm (Elaborable_Apply_To_Field _ term) = term export -getFieldUpdatePath : Elaboratable_Field_Update' nm -> List String -getFieldUpdatePath (Elaboratable_Set_Field path _) = path -getFieldUpdatePath (Elaboratable_Apply_To_Field path _) = path +getFieldUpdatePath : Elaborable_Field_Update' nm -> List String +getFieldUpdatePath (Elaborable_Set_Field path _) = path +getFieldUpdatePath (Elaborable_Apply_To_Field path _) = path export -mapFieldUpdateTerm : (RawImp' nm -> RawImp' nm) -> Elaboratable_Field_Update' nm -> Elaboratable_Field_Update' nm -mapFieldUpdateTerm f (Elaboratable_Set_Field x term) = Elaboratable_Set_Field x (f term) -mapFieldUpdateTerm f (Elaboratable_Apply_To_Field x term) = Elaboratable_Apply_To_Field x (f term) +mapFieldUpdateTerm : (RawImp' nm -> RawImp' nm) -> Elaborable_Field_Update' nm -> Elaborable_Field_Update' nm +mapFieldUpdateTerm f (Elaborable_Set_Field x term) = Elaborable_Set_Field x (f term) +mapFieldUpdateTerm f (Elaborable_Apply_To_Field x term) = Elaborable_Apply_To_Field x (f term) export is_primitive_value : RawImp' nm -> Maybe Constant -is_primitive_value (Elaboratable_Primitive_Value _ c) = Just c +is_primitive_value (Elaborable_Primitive_Value _ c) = Just c is_primitive_value _ = Nothing -- REPL commands for TTImp interaction @@ -572,61 +572,61 @@ mapAltType _ u = u export lhsInCurrentNS : {auto c : Ref Ctxt Defs} -> NestedNames vars -> RawImp -> Core RawImp -lhsInCurrentNS nest (Elaboratable_Apply loc f a) +lhsInCurrentNS nest (Elaborable_Apply loc f a) = do f' <- lhsInCurrentNS nest f - pure (Elaboratable_Apply loc f' a) -lhsInCurrentNS nest (Elaboratable_Automatic_Apply loc f a) + pure (Elaborable_Apply loc f' a) +lhsInCurrentNS nest (Elaborable_Automatic_Apply loc f a) = do f' <- lhsInCurrentNS nest f - pure (Elaboratable_Automatic_Apply loc f' a) -lhsInCurrentNS nest (Elaboratable_Named_Apply loc f n a) + pure (Elaborable_Automatic_Apply loc f' a) +lhsInCurrentNS nest (Elaborable_Named_Apply loc f n a) = do f' <- lhsInCurrentNS nest f - pure (Elaboratable_Named_Apply loc f' n a) -lhsInCurrentNS nest (Elaboratable_With_Apply loc f a) + pure (Elaborable_Named_Apply loc f' n a) +lhsInCurrentNS nest (Elaborable_With_Apply loc f a) = do f' <- lhsInCurrentNS nest f - pure (Elaboratable_With_Apply loc f' a) -lhsInCurrentNS nest tm@(Elaboratable_Name loc (NS {})) = pure tm -- leave explicit NS alone -lhsInCurrentNS nest (Elaboratable_Name loc n) + pure (Elaborable_With_Apply loc f' a) +lhsInCurrentNS nest tm@(Elaborable_Name loc (NS {})) = pure tm -- leave explicit NS alone +lhsInCurrentNS nest (Elaborable_Name loc n) = case lookup n (names nest) of Nothing => do n' <- inCurrentNS n - pure (Elaboratable_Name loc n') + pure (Elaborable_Name loc n') -- If it's one of the names in the current nested block, we'll -- be rewriting it during elaboration to be in the scope of the -- parent name. - Just _ => pure (Elaboratable_Name loc n) + Just _ => pure (Elaborable_Name loc n) lhsInCurrentNS nest tm = pure tm export find_names_to_bind : RawImp' nm -> List String -find_names_to_bind (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) +find_names_to_bind (Elaborable_Dependent_Function_Type fc rig p mn aty retty) = find_names_to_bind aty ++ find_names_to_bind retty -find_names_to_bind (Elaboratable_Lambda fc rig p n aty sc) +find_names_to_bind (Elaborable_Lambda fc rig p n aty sc) = find_names_to_bind aty ++ find_names_to_bind sc -find_names_to_bind (Elaboratable_Apply fc fn av) +find_names_to_bind (Elaborable_Apply fc fn av) = find_names_to_bind fn ++ find_names_to_bind av -find_names_to_bind (Elaboratable_Automatic_Apply fc fn av) +find_names_to_bind (Elaborable_Automatic_Apply fc fn av) = find_names_to_bind fn ++ find_names_to_bind av -find_names_to_bind (Elaboratable_Named_Apply _ fn _ av) +find_names_to_bind (Elaborable_Named_Apply _ fn _ av) = find_names_to_bind fn ++ find_names_to_bind av -find_names_to_bind (Elaboratable_With_Apply fc fn av) +find_names_to_bind (Elaborable_With_Apply fc fn av) = find_names_to_bind fn ++ find_names_to_bind av -find_names_to_bind (Elaboratable_As_Pattern fc _ _ (UN (Basic n)) pat) +find_names_to_bind (Elaborable_As_Pattern fc _ _ (UN (Basic n)) pat) = n :: find_names_to_bind pat -find_names_to_bind (Elaboratable_As_Pattern fc _ _ n pat) +find_names_to_bind (Elaborable_As_Pattern fc _ _ n pat) = find_names_to_bind pat -find_names_to_bind (Elaboratable_Must_Unify fc r pat) +find_names_to_bind (Elaborable_Must_Unify fc r pat) = find_names_to_bind pat -find_names_to_bind (Elaboratable_Alternative fc u alts) +find_names_to_bind (Elaborable_Alternative fc u alts) = concatMap find_names_to_bind alts -find_names_to_bind (Elaboratable_Delayed_Type fc _ ty) = find_names_to_bind ty -find_names_to_bind (Elaboratable_Delay fc tm) = find_names_to_bind tm -find_names_to_bind (Elaboratable_Force fc tm) = find_names_to_bind tm -find_names_to_bind (Elaboratable_Quote fc tm) = find_names_to_bind tm -find_names_to_bind (Elaboratable_Unquote fc tm) = find_names_to_bind tm -find_names_to_bind (Elaboratable_Run_Elaborator fc _ tm) = find_names_to_bind tm -find_names_to_bind (Elaboratable_Bind_Here _ _ tm) = find_names_to_bind tm -find_names_to_bind (Elaboratable_Bind_Name _ (UN (Basic n))) = [n] -find_names_to_bind (Elaboratable_Record_Update fc updates tm) +find_names_to_bind (Elaborable_Delayed_Type fc _ ty) = find_names_to_bind ty +find_names_to_bind (Elaborable_Delay fc tm) = find_names_to_bind tm +find_names_to_bind (Elaborable_Force fc tm) = find_names_to_bind tm +find_names_to_bind (Elaborable_Quote fc tm) = find_names_to_bind tm +find_names_to_bind (Elaborable_Unquote fc tm) = find_names_to_bind tm +find_names_to_bind (Elaborable_Run_Elaborator fc _ tm) = find_names_to_bind tm +find_names_to_bind (Elaborable_Bind_Here _ _ tm) = find_names_to_bind tm +find_names_to_bind (Elaborable_Bind_Name _ (UN (Basic n))) = [n] +find_names_to_bind (Elaborable_Record_Update fc updates tm) = find_names_to_bind tm ++ concatMap (find_names_to_bind . getFieldUpdateTerm) updates -- We've skipped lambda, case, let and local - rather than guess where the -- name should be bound, leave it to the programmer @@ -634,40 +634,40 @@ find_names_to_bind tm = [] export findImplicits : RawImp' nm -> List String -findImplicits (Elaboratable_Dependent_Function_Type fc rig p (Just (UN (Basic mn))) aty retty) +findImplicits (Elaborable_Dependent_Function_Type fc rig p (Just (UN (Basic mn))) aty retty) = mn :: findImplicits aty ++ findImplicits retty -findImplicits (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) +findImplicits (Elaborable_Dependent_Function_Type fc rig p mn aty retty) = findImplicits aty ++ findImplicits retty -findImplicits (Elaboratable_Lambda fc rig p n aty sc) +findImplicits (Elaborable_Lambda fc rig p n aty sc) = findImplicits aty ++ findImplicits sc -findImplicits (Elaboratable_Apply fc fn av) +findImplicits (Elaborable_Apply fc fn av) = findImplicits fn ++ findImplicits av -findImplicits (Elaboratable_Automatic_Apply _ fn av) +findImplicits (Elaborable_Automatic_Apply _ fn av) = findImplicits fn ++ findImplicits av -findImplicits (Elaboratable_Named_Apply _ fn _ av) +findImplicits (Elaborable_Named_Apply _ fn _ av) = findImplicits fn ++ findImplicits av -findImplicits (Elaboratable_With_Apply fc fn av) +findImplicits (Elaborable_With_Apply fc fn av) = findImplicits fn ++ findImplicits av -findImplicits (Elaboratable_As_Pattern fc _ _ n pat) +findImplicits (Elaborable_As_Pattern fc _ _ n pat) = findImplicits pat -findImplicits (Elaboratable_Must_Unify fc r pat) +findImplicits (Elaborable_Must_Unify fc r pat) = findImplicits pat -findImplicits (Elaboratable_Alternative fc u alts) +findImplicits (Elaborable_Alternative fc u alts) = concatMap findImplicits alts -findImplicits (Elaboratable_Delayed_Type fc _ ty) = findImplicits ty -findImplicits (Elaboratable_Delay fc tm) = findImplicits tm -findImplicits (Elaboratable_Force fc tm) = findImplicits tm -findImplicits (Elaboratable_Quote fc tm) = findImplicits tm -findImplicits (Elaboratable_Unquote fc tm) = findImplicits tm -findImplicits (Elaboratable_Run_Elaborator fc _ tm) = findImplicits tm -findImplicits (Elaboratable_Bind_Name _ (UN (Basic n))) = [n] -findImplicits (Elaboratable_Record_Update fc updates tm) +findImplicits (Elaborable_Delayed_Type fc _ ty) = findImplicits ty +findImplicits (Elaborable_Delay fc tm) = findImplicits tm +findImplicits (Elaborable_Force fc tm) = findImplicits tm +findImplicits (Elaborable_Quote fc tm) = findImplicits tm +findImplicits (Elaborable_Unquote fc tm) = findImplicits tm +findImplicits (Elaborable_Run_Elaborator fc _ tm) = findImplicits tm +findImplicits (Elaborable_Bind_Name _ (UN (Basic n))) = [n] +findImplicits (Elaborable_Record_Update fc updates tm) = findImplicits tm ++ concatMap (findImplicits . getFieldUpdateTerm) updates findImplicits tm = [] -- Update the lhs of a clause so that any implicits named in the type are -- bound as @-patterns (unless they're already explicitly bound or appear as --- Elaboratable_Bind_Name anywhere else in the pattern) so that they will be available on the +-- Elaborable_Bind_Name anywhere else in the pattern) so that they will be available on the -- rhs export implicitsAs : {auto c : Ref Ctxt Defs} -> @@ -685,25 +685,25 @@ implicitsAs n defs ns tm -- More precisely, implicit and explicit arguments are recorded separately, -- into `is` and `es` respectively. setAs : List (Maybe Name) -> List (Maybe Name) -> RawImp -> Core RawImp - setAs is es (Elaboratable_Apply loc f a) + setAs is es (Elaborable_Apply loc f a) = do f' <- setAs is (Nothing :: es) f - pure $ Elaboratable_Apply loc f' a - setAs is es (Elaboratable_Automatic_Apply loc f a) + pure $ Elaborable_Apply loc f' a + setAs is es (Elaborable_Automatic_Apply loc f a) = do f' <- setAs (Nothing :: is) es f - pure $ Elaboratable_Automatic_Apply loc f' a - setAs is es (Elaboratable_Named_Apply loc f n a) + pure $ Elaborable_Automatic_Apply loc f' a + setAs is es (Elaborable_Named_Apply loc f n a) = do f' <- setAs (Just n :: is) (Just n :: es) f - pure $ Elaboratable_Named_Apply loc f' n a - setAs is es (Elaboratable_With_Apply loc f a) + pure $ Elaborable_Named_Apply loc f' n a + setAs is es (Elaborable_With_Apply loc f a) = do f' <- setAs is es f - pure $ Elaboratable_With_Apply loc f' a - setAs is es (Elaboratable_Name loc nm) + pure $ Elaborable_With_Apply loc f' a + setAs is es (Elaborable_Name loc nm) -- #834 Use the (already) resolved name rather than the local one = case !(lookupTyExact (Resolved n) (gamma defs)) of Nothing => do log "declare.def.lhs.implicits" 30 $ "Could not find variable " ++ show n - pure $ Elaboratable_Name loc nm + pure $ Elaborable_Name loc nm Just ty => do ty' <- nf defs Env.empty ty implicits <- findImps is es ns ty' @@ -711,7 +711,7 @@ implicitsAs n defs ns tm "\n In the type of " ++ show n ++ ": " ++ show ty ++ "\n Using locals: " ++ show ns ++ "\n Found implicits: " ++ show implicits - pure $ impAs (virtualiseFC loc) implicits (Elaboratable_Name loc nm) + pure $ impAs (virtualiseFC loc) implicits (Elaborable_Name loc nm) where -- If there's an @{c} in the list of given implicits, that's the next -- autoimplicit, so don't rewrite the LHS and update the list of given @@ -776,17 +776,17 @@ implicitsAs n defs ns tm impAs loc' [] tm = tm impAs loc' ((nm@(UN (Basic _)), AutoImplicit) :: ns) tm = impAs loc' ns $ - Elaboratable_Named_Apply loc' tm nm (Elaboratable_Bind_Name loc' nm) + Elaborable_Named_Apply loc' tm nm (Elaborable_Bind_Name loc' nm) impAs loc' ((n, Implicit) :: ns) tm = impAs loc' ns $ - Elaboratable_Named_Apply loc' tm n - (Elaboratable_As_Pattern loc' EmptyFC UseLeft n (Implicit loc' True)) + Elaborable_Named_Apply loc' tm n + (Elaborable_As_Pattern loc' EmptyFC UseLeft n (Implicit loc' True)) impAs loc' ((n, DefImplicit t) :: ns) tm = impAs loc' ns $ - Elaboratable_Named_Apply loc' tm n - (Elaboratable_As_Pattern loc' EmptyFC UseLeft n (Implicit loc' True)) + Elaborable_Named_Apply loc' tm n + (Elaborable_As_Pattern loc' EmptyFC UseLeft n (Implicit loc' True)) impAs loc' (_ :: ns) tm = impAs loc' ns tm setAs is es tm = pure tm @@ -802,7 +802,7 @@ definedInBlock ns decls = getName : ImpTy -> Name getName = (.tyName.val) - getFieldName : Elaboratable_Field -> Name + getFieldName : Elaborable_Field -> Name getFieldName f = f.name.val expandNS : Namespace -> Name -> Name @@ -814,15 +814,15 @@ definedInBlock ns decls = _ => n defName : Namespace -> SortedSet Name -> ImpDecl -> SortedSet Name - defName ns acc (Elaboratable_Claim c) = insert (expandNS ns (getName c.val.type)) acc - defName ns acc (Elaboratable_Definition _ nm _) = insert (expandNS ns nm) acc - defName ns acc (Elaboratable_Data_Declaration _ _ _ (MkImpData _ n _ _ cons)) + defName ns acc (Elaborable_Claim c) = insert (expandNS ns (getName c.val.type)) acc + defName ns acc (Elaborable_Definition _ nm _) = insert (expandNS ns nm) acc + defName ns acc (Elaborable_Data_Declaration _ _ _ (MkImpData _ n _ _ cons)) = foldl (flip insert) acc $ expandNS ns n :: map (expandNS ns . getName) cons - defName ns acc (Elaboratable_Data_Declaration _ _ _ (MkImpLater _ n _)) = insert (expandNS ns n) acc - defName ns acc (Elaboratable_Parameter_Block _ _ pds) = foldl (defName ns) acc pds - defName ns acc (Elaboratable_Expected_Failure _ _ nds) = foldl (defName ns) acc nds - defName ns acc (Elaboratable_Namespace_Block _ n nds) = foldl (defName (ns <.> n)) acc nds - defName ns acc (Elaboratable_Record_Declaration _ fldns _ _ rec) + defName ns acc (Elaborable_Data_Declaration _ _ _ (MkImpLater _ n _)) = insert (expandNS ns n) acc + defName ns acc (Elaborable_Parameter_Block _ _ pds) = foldl (defName ns) acc pds + defName ns acc (Elaborable_Expected_Failure _ _ nds) = foldl (defName ns) acc nds + defName ns acc (Elaborable_Namespace_Block _ n nds) = foldl (defName (ns <.> n)) acc nds + defName ns acc (Elaborable_Record_Declaration _ fldns _ _ rec) = foldl (flip insert) acc $ expandNS ns rec.val.body.name.val :: all where fldns' : Namespace @@ -848,72 +848,72 @@ definedInBlock ns decls = all : List Name all = expandNS ns rec.val.header.name.val :: map (expandNS fldns') (fnsRF ++ fnsUN) - defName ns acc (Elaboratable_Pragma _ pns _) = foldl (flip insert) acc $ map (expandNS ns) pns + defName ns acc (Elaborable_Pragma _ pns _) = foldl (flip insert) acc $ map (expandNS ns) pns defName _ acc _ = acc export -is_elaboratable_name : RawImp' nm -> Maybe (FC, nm) -is_elaboratable_name (Elaboratable_Name fc v) = Just (fc, v) -is_elaboratable_name _ = Nothing +is_elaborable_name : RawImp' nm -> Maybe (FC, nm) +is_elaborable_name (Elaborable_Name fc v) = Just (fc, v) +is_elaborable_name _ = Nothing export -is_elaboratable_bound_name : RawImp' nm -> Maybe (FC, Name) -is_elaboratable_bound_name (Elaboratable_Bind_Name fc v) = Just (fc, v) -is_elaboratable_bound_name _ = Nothing +is_elaborable_bound_name : RawImp' nm -> Maybe (FC, Name) +is_elaborable_bound_name (Elaborable_Bind_Name fc v) = Just (fc, v) +is_elaborable_bound_name _ = Nothing export getFC : RawImp' nm -> FC -getFC (Elaboratable_Name x _) = x -getFC (Elaboratable_Dependent_Function_Type x _ _ _ _ _) = x -getFC (Elaboratable_Lambda x _ _ _ _ _) = x -getFC (Elaboratable_Binding x _ _ _ _ _ _) = x -getFC (Elaboratable_Case x _ _ _ _) = x -getFC (Elaboratable_Local_Definitions x _ _) = x -getFC (Elaboratable_Case_Local_Definition x _ _ _ _) = x -getFC (Elaboratable_Record_Update x _ _) = x -getFC (Elaboratable_Apply x _ _) = x -getFC (Elaboratable_Named_Apply x _ _ _) = x -getFC (Elaboratable_Automatic_Apply x _ _) = x -getFC (Elaboratable_With_Apply x _ _) = x -getFC (Elaboratable_Search x _) = x -getFC (Elaboratable_Alternative x _ _) = x -getFC (Elaboratable_Rewrite x _ _) = x -getFC (Elaboratable_Coerced x _) = x -getFC (Elaboratable_Primitive_Value x _) = x -getFC (Elaboratable_Hole x _) = x -getFC (Elaboratable_Unification_Log x _ _) = x -getFC (Elaboratable_Type_Universe x) = x -getFC (Elaboratable_Bind_Name x _) = x -getFC (Elaboratable_Bind_Here x _ _) = x -getFC (Elaboratable_Must_Unify x _ _) = x -getFC (Elaboratable_Delayed_Type x _ _) = x -getFC (Elaboratable_Delay x _) = x -getFC (Elaboratable_Force x _) = x -getFC (Elaboratable_Quote x _) = x -getFC (Elaboratable_Quote_Name x _) = x -getFC (Elaboratable_Quote_Declarations x _) = x -getFC (Elaboratable_Unquote x _) = x -getFC (Elaboratable_Run_Elaborator x _ _) = x -getFC (Elaboratable_As_Pattern x _ _ _ _) = x +getFC (Elaborable_Name x _) = x +getFC (Elaborable_Dependent_Function_Type x _ _ _ _ _) = x +getFC (Elaborable_Lambda x _ _ _ _ _) = x +getFC (Elaborable_Binding x _ _ _ _ _ _) = x +getFC (Elaborable_Case x _ _ _ _) = x +getFC (Elaborable_Local_Definitions x _ _) = x +getFC (Elaborable_Case_Local_Definition x _ _ _ _) = x +getFC (Elaborable_Record_Update x _ _) = x +getFC (Elaborable_Apply x _ _) = x +getFC (Elaborable_Named_Apply x _ _ _) = x +getFC (Elaborable_Automatic_Apply x _ _) = x +getFC (Elaborable_With_Apply x _ _) = x +getFC (Elaborable_Search x _) = x +getFC (Elaborable_Alternative x _ _) = x +getFC (Elaborable_Rewrite x _ _) = x +getFC (Elaborable_Coerced x _) = x +getFC (Elaborable_Primitive_Value x _) = x +getFC (Elaborable_Hole x _) = x +getFC (Elaborable_Unification_Log x _ _) = x +getFC (Elaborable_Type_Universe x) = x +getFC (Elaborable_Bind_Name x _) = x +getFC (Elaborable_Bind_Here x _ _) = x +getFC (Elaborable_Must_Unify x _ _) = x +getFC (Elaborable_Delayed_Type x _ _) = x +getFC (Elaborable_Delay x _) = x +getFC (Elaborable_Force x _) = x +getFC (Elaborable_Quote x _) = x +getFC (Elaborable_Quote_Name x _) = x +getFC (Elaborable_Quote_Declarations x _) = x +getFC (Elaborable_Unquote x _) = x +getFC (Elaborable_Run_Elaborator x _ _) = x +getFC (Elaborable_As_Pattern x _ _ _ _) = x getFC (Implicit x _) = x -getFC (Elaboratable_With_Unambiguous_Names x _ _) = x +getFC (Elaborable_With_Unambiguous_Names x _ _) = x namespace ImpDecl public export getFC : ImpDecl' nm -> FC - getFC (Elaboratable_Claim c) = c.fc - getFC (Elaboratable_Data_Declaration fc _ _ _) = fc - getFC (Elaboratable_Definition fc _ _) = fc - getFC (Elaboratable_Parameter_Block fc _ _) = fc - getFC (Elaboratable_Record_Declaration fc _ _ _ _) = fc - getFC (Elaboratable_Expected_Failure fc _ _) = fc - getFC (Elaboratable_Namespace_Block fc _ _) = fc - getFC (Elaboratable_Transformation fc _ _ _) = fc - getFC (Elaboratable_Run_Elaborator_Declaration fc _) = fc - getFC (Elaboratable_Pragma fc _ _) = fc - getFC (Elaboratable_Logging _) = EmptyFC - getFC (Elaboratable_Builtin_Declaration fc _ _) = fc + getFC (Elaborable_Claim c) = c.fc + getFC (Elaborable_Data_Declaration fc _ _ _) = fc + getFC (Elaborable_Definition fc _ _) = fc + getFC (Elaborable_Parameter_Block fc _ _) = fc + getFC (Elaborable_Record_Declaration fc _ _ _ _) = fc + getFC (Elaborable_Expected_Failure fc _ _) = fc + getFC (Elaborable_Namespace_Block fc _ _) = fc + getFC (Elaborable_Transformation fc _ _ _) = fc + getFC (Elaborable_Run_Elaborator_Declaration fc _) = fc + getFC (Elaborable_Pragma fc _ _) = fc + getFC (Elaborable_Logging _) = EmptyFC + getFC (Elaborable_Builtin_Declaration fc _ _) = fc public export data Arg' nm @@ -927,8 +927,8 @@ Arg : Type Arg = Arg' Name public export -Kinded_Elaboratable_Argument : Type -Kinded_Elaboratable_Argument = Arg' KindedName +Kinded_Elaborable_Argument : Type +Kinded_Elaborable_Argument = Arg' KindedName export isExplicit : Arg' nm -> Maybe (FC, RawImp' nm) @@ -936,10 +936,10 @@ isExplicit (Explicit fc t) = Just (fc, t) isExplicit _ = Nothing export -elaboratable_argument_term : Arg' nm -> RawImp' nm -elaboratable_argument_term (Explicit _ t) = t -elaboratable_argument_term (Auto _ t) = t -elaboratable_argument_term (Named _ _ t) = t +elaborable_argument_term : Arg' nm -> RawImp' nm +elaborable_argument_term (Explicit _ t) = t +elaborable_argument_term (Auto _ t) = t +elaborable_argument_term (Named _ _ t) = t export covering @@ -950,18 +950,18 @@ Show nm => Show (Arg' nm) where export getFnArgs : RawImp' nm -> List (Arg' nm) -> (RawImp' nm, List (Arg' nm)) -getFnArgs (Elaboratable_Apply fc f arg) args = getFnArgs f (Explicit fc arg :: args) -getFnArgs (Elaboratable_Named_Apply fc f n arg) args = getFnArgs f (Named fc n arg :: args) -getFnArgs (Elaboratable_Automatic_Apply fc f arg) args = getFnArgs f (Auto fc arg :: args) +getFnArgs (Elaborable_Apply fc f arg) args = getFnArgs f (Explicit fc arg :: args) +getFnArgs (Elaborable_Named_Apply fc f n arg) args = getFnArgs f (Named fc n arg :: args) +getFnArgs (Elaborable_Automatic_Apply fc f arg) args = getFnArgs f (Auto fc arg :: args) getFnArgs tm args = (tm, args) -- TODO: merge these definitions namespace Arg export apply : RawImp' nm -> List (Arg' nm) -> RawImp' nm - apply f (Explicit fc a :: args) = apply (Elaboratable_Apply fc f a) args - apply f (Auto fc a :: args) = apply (Elaboratable_Automatic_Apply fc f a) args - apply f (Named fc n a :: args) = apply (Elaboratable_Named_Apply fc f n a) args + apply f (Explicit fc a :: args) = apply (Elaborable_Apply fc f a) args + apply f (Auto fc a :: args) = apply (Elaborable_Automatic_Apply fc f a) args + apply f (Named fc n a :: args) = apply (Elaborable_Named_Apply fc f n a) args apply f [] = f export @@ -969,7 +969,7 @@ apply : RawImp' nm -> List (RawImp' nm) -> RawImp' nm apply f [] = f apply f (x :: xs) = let fFC = getFC f in - apply (Elaboratable_Apply (fromMaybe fFC (mergeFC fFC (getFC x))) f x) xs + apply (Elaborable_Apply (fromMaybe fFC (mergeFC fFC (getFC x))) f x) xs export gapply : RawImp' nm -> List (Maybe Name, RawImp' nm) -> RawImp' nm @@ -977,18 +977,18 @@ gapply f [] = f gapply f (x :: xs) = gapply (uncurry (app f) x) xs where app : RawImp' nm -> Maybe Name -> RawImp' nm -> RawImp' nm - app f Nothing x = Elaboratable_Apply (getFC f) f x - app f (Just nm) x = Elaboratable_Named_Apply (getFC f) f nm x + app f Nothing x = Elaborable_Apply (getFC f) f x + app f (Just nm) x = Elaborable_Named_Apply (getFC f) f nm x export getFn : RawImp' nm -> RawImp' nm -getFn (Elaboratable_Apply _ f _) = getFn f -getFn (Elaboratable_With_Apply _ f _) = getFn f -getFn (Elaboratable_Named_Apply _ f _ _) = getFn f -getFn (Elaboratable_Automatic_Apply _ f _) = getFn f -getFn (Elaboratable_As_Pattern _ _ _ _ f) = getFn f -getFn (Elaboratable_Must_Unify _ _ f) = getFn f +getFn (Elaborable_Apply _ f _) = getFn f +getFn (Elaborable_With_Apply _ f _) = getFn f +getFn (Elaborable_Named_Apply _ f _ _) = getFn f +getFn (Elaborable_Automatic_Apply _ f _) = getFn f +getFn (Elaborable_As_Pattern _ _ _ _ f) = getFn f +getFn (Elaborable_Must_Unify _ _ f) = getFn f getFn f = f -- Log message with a RawImp diff --git a/TTImp/TTImp/Functor.idr b/TTImp/TTImp/Functor.idr index 978fbab965..8fd9bca139 100644 --- a/TTImp/TTImp/Functor.idr +++ b/TTImp/TTImp/Functor.idr @@ -10,73 +10,73 @@ mutual export Functor RawImp' where - map f (Elaboratable_Name fc nm) = Elaboratable_Name fc (f nm) - map f (Elaboratable_Dependent_Function_Type fc rig info nm a sc) - = Elaboratable_Dependent_Function_Type fc rig (map (map f) info) nm (map f a) (map f sc) - map f (Elaboratable_Lambda fc rig info nm a sc) - = Elaboratable_Lambda fc rig (map (map f) info) nm (map f a) (map f sc) - map f (Elaboratable_Binding fc lhsFC rig nm ty val sc) - = Elaboratable_Binding fc lhsFC rig nm (map f ty) (map f val) (map f sc) - map f (Elaboratable_Case fc opts sc ty cls) - = Elaboratable_Case fc (map (map f) opts) (map f sc) (map f ty) (map (map f) cls) - map f (Elaboratable_Local_Definitions fc ds sc) - = Elaboratable_Local_Definitions fc (map (map f) ds) (map f sc) - map f (Elaboratable_Case_Local_Definition fc userN intN args sc) - = Elaboratable_Case_Local_Definition fc userN intN args (map f sc) - map f (Elaboratable_Record_Update fc upds rec) - = Elaboratable_Record_Update fc (map (map f) upds) (map f rec) - map f (Elaboratable_Apply fc fn t) - = Elaboratable_Apply fc (map f fn) (map f t) - map f (Elaboratable_Automatic_Apply fc fn t) - = Elaboratable_Automatic_Apply fc (map f fn) (map f t) - map f (Elaboratable_Named_Apply fc fn nm t) - = Elaboratable_Named_Apply fc (map f fn) nm (map f t) - map f (Elaboratable_With_Apply fc fn t) - = Elaboratable_With_Apply fc (map f fn) (map f t) - map f (Elaboratable_Search fc n) - = Elaboratable_Search fc n - map f (Elaboratable_Alternative fc alt ts) - = Elaboratable_Alternative fc (map f alt) (map (map f) ts) - map f (Elaboratable_Rewrite fc e t) - = Elaboratable_Rewrite fc (map f e) (map f t) - map f (Elaboratable_Coerced fc e) - = Elaboratable_Coerced fc (map f e) - map f (Elaboratable_Bind_Here fc bd t) - = Elaboratable_Bind_Here fc bd (map f t) - map f (Elaboratable_Bind_Name fc str) - = Elaboratable_Bind_Name fc str - map f (Elaboratable_As_Pattern fc nmFC side nm t) - = Elaboratable_As_Pattern fc nmFC side nm (map f t) - map f (Elaboratable_Must_Unify fc reason t) - = Elaboratable_Must_Unify fc reason (map f t) - map f (Elaboratable_Delayed_Type fc reason t) - = Elaboratable_Delayed_Type fc reason (map f t) - map f (Elaboratable_Delay fc t) - = Elaboratable_Delay fc (map f t) - map f (Elaboratable_Force fc t) - = Elaboratable_Force fc (map f t) - map f (Elaboratable_Quote fc t) - = Elaboratable_Quote fc (map f t) - map f (Elaboratable_Quote_Name fc nm) - = Elaboratable_Quote_Name fc nm - map f (Elaboratable_Quote_Declarations fc ds) - = Elaboratable_Quote_Declarations fc (map (map f) ds) - map f (Elaboratable_Unquote fc t) - = Elaboratable_Unquote fc (map f t) - map f (Elaboratable_Run_Elaborator fc re t) - = Elaboratable_Run_Elaborator fc re (map f t) - map f (Elaboratable_Primitive_Value fc c) - = Elaboratable_Primitive_Value fc c - map f (Elaboratable_Type_Universe fc) - = Elaboratable_Type_Universe fc - map f (Elaboratable_Hole fc str) - = Elaboratable_Hole fc str - map f (Elaboratable_Unification_Log fc lvl t) - = Elaboratable_Unification_Log fc lvl (map f t) + map f (Elaborable_Name fc nm) = Elaborable_Name fc (f nm) + map f (Elaborable_Dependent_Function_Type fc rig info nm a sc) + = Elaborable_Dependent_Function_Type fc rig (map (map f) info) nm (map f a) (map f sc) + map f (Elaborable_Lambda fc rig info nm a sc) + = Elaborable_Lambda fc rig (map (map f) info) nm (map f a) (map f sc) + map f (Elaborable_Binding fc lhsFC rig nm ty val sc) + = Elaborable_Binding fc lhsFC rig nm (map f ty) (map f val) (map f sc) + map f (Elaborable_Case fc opts sc ty cls) + = Elaborable_Case fc (map (map f) opts) (map f sc) (map f ty) (map (map f) cls) + map f (Elaborable_Local_Definitions fc ds sc) + = Elaborable_Local_Definitions fc (map (map f) ds) (map f sc) + map f (Elaborable_Case_Local_Definition fc userN intN args sc) + = Elaborable_Case_Local_Definition fc userN intN args (map f sc) + map f (Elaborable_Record_Update fc upds rec) + = Elaborable_Record_Update fc (map (map f) upds) (map f rec) + map f (Elaborable_Apply fc fn t) + = Elaborable_Apply fc (map f fn) (map f t) + map f (Elaborable_Automatic_Apply fc fn t) + = Elaborable_Automatic_Apply fc (map f fn) (map f t) + map f (Elaborable_Named_Apply fc fn nm t) + = Elaborable_Named_Apply fc (map f fn) nm (map f t) + map f (Elaborable_With_Apply fc fn t) + = Elaborable_With_Apply fc (map f fn) (map f t) + map f (Elaborable_Search fc n) + = Elaborable_Search fc n + map f (Elaborable_Alternative fc alt ts) + = Elaborable_Alternative fc (map f alt) (map (map f) ts) + map f (Elaborable_Rewrite fc e t) + = Elaborable_Rewrite fc (map f e) (map f t) + map f (Elaborable_Coerced fc e) + = Elaborable_Coerced fc (map f e) + map f (Elaborable_Bind_Here fc bd t) + = Elaborable_Bind_Here fc bd (map f t) + map f (Elaborable_Bind_Name fc str) + = Elaborable_Bind_Name fc str + map f (Elaborable_As_Pattern fc nmFC side nm t) + = Elaborable_As_Pattern fc nmFC side nm (map f t) + map f (Elaborable_Must_Unify fc reason t) + = Elaborable_Must_Unify fc reason (map f t) + map f (Elaborable_Delayed_Type fc reason t) + = Elaborable_Delayed_Type fc reason (map f t) + map f (Elaborable_Delay fc t) + = Elaborable_Delay fc (map f t) + map f (Elaborable_Force fc t) + = Elaborable_Force fc (map f t) + map f (Elaborable_Quote fc t) + = Elaborable_Quote fc (map f t) + map f (Elaborable_Quote_Name fc nm) + = Elaborable_Quote_Name fc nm + map f (Elaborable_Quote_Declarations fc ds) + = Elaborable_Quote_Declarations fc (map (map f) ds) + map f (Elaborable_Unquote fc t) + = Elaborable_Unquote fc (map f t) + map f (Elaborable_Run_Elaborator fc re t) + = Elaborable_Run_Elaborator fc re (map f t) + map f (Elaborable_Primitive_Value fc c) + = Elaborable_Primitive_Value fc c + map f (Elaborable_Type_Universe fc) + = Elaborable_Type_Universe fc + map f (Elaborable_Hole fc str) + = Elaborable_Hole fc str + map f (Elaborable_Unification_Log fc lvl t) + = Elaborable_Unification_Log fc lvl (map f t) map f (Implicit fc b) = Implicit fc b - map f (Elaboratable_With_Unambiguous_Names fc ns t) - = Elaboratable_With_Unambiguous_Names fc ns (map f t) + map f (Elaborable_With_Unambiguous_Names fc ns t) + = Elaborable_With_Unambiguous_Names fc ns (map f t) export Functor ImpClause' where @@ -88,33 +88,33 @@ mutual = ImpossibleClause fc (map f lhs) export - Functor Elaboratable_Claim_Data where - map f (Make_Elaboratable_Claim_Data rig vis opts ty) - = Make_Elaboratable_Claim_Data rig vis (map (map f) opts) (map (map f) ty) + Functor Elaborable_Claim_Data where + map f (Make_Elaborable_Claim_Data rig vis opts ty) + = Make_Elaborable_Claim_Data rig vis (map (map f) opts) (map (map f) ty) export Functor ImpDecl' where - map f (Elaboratable_Claim c) - = Elaboratable_Claim (map (map f) c) - map f (Elaboratable_Data_Declaration fc vis mbtot dt) - = Elaboratable_Data_Declaration fc vis mbtot (map f dt) - map f (Elaboratable_Definition fc nm cls) - = Elaboratable_Definition fc nm (map (map f) cls) - map f (Elaboratable_Parameter_Block fc ps ds) - = Elaboratable_Parameter_Block fc (map (map (map (map f))) ps) (map (map f) ds) - map f (Elaboratable_Record_Declaration fc cs vis mbtot rec) - = Elaboratable_Record_Declaration fc cs vis mbtot (map (map f) rec) - map f (Elaboratable_Expected_Failure fc msg ds) - = Elaboratable_Expected_Failure fc msg (map (map f) ds) - map f (Elaboratable_Namespace_Block fc ns ds) - = Elaboratable_Namespace_Block fc ns (map (map f) ds) - map f (Elaboratable_Transformation fc n lhs rhs) - = Elaboratable_Transformation fc n (map f lhs) (map f rhs) - map f (Elaboratable_Run_Elaborator_Declaration fc t) - = Elaboratable_Run_Elaborator_Declaration fc (map f t) - map f (Elaboratable_Pragma fc xs k) = Elaboratable_Pragma fc xs k - map f (Elaboratable_Logging x) = Elaboratable_Logging x - map f (Elaboratable_Builtin_Declaration fc ty n) = Elaboratable_Builtin_Declaration fc ty n + map f (Elaborable_Claim c) + = Elaborable_Claim (map (map f) c) + map f (Elaborable_Data_Declaration fc vis mbtot dt) + = Elaborable_Data_Declaration fc vis mbtot (map f dt) + map f (Elaborable_Definition fc nm cls) + = Elaborable_Definition fc nm (map (map f) cls) + map f (Elaborable_Parameter_Block fc ps ds) + = Elaborable_Parameter_Block fc (map (map (map (map f))) ps) (map (map f) ds) + map f (Elaborable_Record_Declaration fc cs vis mbtot rec) + = Elaborable_Record_Declaration fc cs vis mbtot (map (map f) rec) + map f (Elaborable_Expected_Failure fc msg ds) + = Elaborable_Expected_Failure fc msg (map (map f) ds) + map f (Elaborable_Namespace_Block fc ns ds) + = Elaborable_Namespace_Block fc ns (map (map f) ds) + map f (Elaborable_Transformation fc n lhs rhs) + = Elaborable_Transformation fc n (map f lhs) (map f rhs) + map f (Elaborable_Run_Elaborator_Declaration fc t) + = Elaborable_Run_Elaborator_Declaration fc (map f t) + map f (Elaborable_Pragma fc xs k) = Elaborable_Pragma fc xs k + map f (Elaborable_Logging x) = Elaborable_Logging x + map f (Elaborable_Builtin_Declaration fc ty n) = Elaborable_Builtin_Declaration fc ty n export Functor FnOpt' where @@ -147,9 +147,9 @@ mutual (map (map (map (map (map f)))) body) export - Functor Elaboratable_Field_Update' where - map f (Elaboratable_Set_Field path t) = Elaboratable_Set_Field path (map f t) - map f (Elaboratable_Apply_To_Field path t) = Elaboratable_Apply_To_Field path (map f t) + Functor Elaborable_Field_Update' where + map f (Elaborable_Set_Field path t) = Elaborable_Set_Field path (map f t) + map f (Elaborable_Apply_To_Field path t) = Elaborable_Apply_To_Field path (map f t) export Functor AltType' where diff --git a/TTImp/TTImp/TTC.idr b/TTImp/TTImp/TTC.idr index 45af76fa54..ec08c80d89 100644 --- a/TTImp/TTImp/TTC.idr +++ b/TTImp/TTImp/TTC.idr @@ -16,191 +16,191 @@ import Libraries.Data.WithDefault mutual export TTC RawImp where - toBuf (Elaboratable_Name fc n) = do tag 0; toBuf fc; toBuf n - toBuf (Elaboratable_Dependent_Function_Type fc r p n argTy retTy) + toBuf (Elaborable_Name fc n) = do tag 0; toBuf fc; toBuf n + toBuf (Elaborable_Dependent_Function_Type fc r p n argTy retTy) = do tag 1; toBuf fc; toBuf r; toBuf p; toBuf n toBuf argTy; toBuf retTy - toBuf (Elaboratable_Lambda fc r p n argTy scope) + toBuf (Elaborable_Lambda fc r p n argTy scope) = do tag 2; toBuf fc; toBuf r; toBuf p; toBuf n; toBuf argTy; toBuf scope - toBuf (Elaboratable_Binding fc lhsFC r n nTy nVal scope) + toBuf (Elaborable_Binding fc lhsFC r n nTy nVal scope) = do tag 3; toBuf fc; toBuf lhsFC; toBuf r; toBuf n; toBuf nTy; toBuf nVal; toBuf scope - toBuf (Elaboratable_Case fc opts y ty xs) + toBuf (Elaborable_Case fc opts y ty xs) = do tag 4; toBuf fc; toBuf opts; toBuf y; toBuf ty; toBuf xs - toBuf (Elaboratable_Local_Definitions fc xs sc) + toBuf (Elaborable_Local_Definitions fc xs sc) = do tag 5; toBuf fc; toBuf xs; toBuf sc - toBuf (Elaboratable_Case_Local_Definition fc _ _ _ sc) + toBuf (Elaborable_Case_Local_Definition fc _ _ _ sc) = toBuf sc - toBuf (Elaboratable_Record_Update fc fs rec) + toBuf (Elaborable_Record_Update fc fs rec) = do tag 6; toBuf fc; toBuf fs; toBuf rec - toBuf (Elaboratable_Apply fc fn arg) + toBuf (Elaborable_Apply fc fn arg) = do tag 7; toBuf fc; toBuf fn; toBuf arg - toBuf (Elaboratable_Named_Apply fc fn y arg) + toBuf (Elaborable_Named_Apply fc fn y arg) = do tag 8; toBuf fc; toBuf fn; toBuf y; toBuf arg - toBuf (Elaboratable_With_Apply fc fn arg) + toBuf (Elaborable_With_Apply fc fn arg) = do tag 9; toBuf fc; toBuf fn; toBuf arg - toBuf (Elaboratable_Search fc depth) + toBuf (Elaborable_Search fc depth) = do tag 10; toBuf fc; toBuf depth - toBuf (Elaboratable_Alternative fc y xs) + toBuf (Elaborable_Alternative fc y xs) = do tag 11; toBuf fc; toBuf y; toBuf xs - toBuf (Elaboratable_Rewrite fc x y) + toBuf (Elaborable_Rewrite fc x y) = do tag 12; toBuf fc; toBuf x; toBuf y - toBuf (Elaboratable_Coerced fc y) + toBuf (Elaborable_Coerced fc y) = do tag 13; toBuf fc; toBuf y - toBuf (Elaboratable_Bind_Here fc m y) + toBuf (Elaborable_Bind_Here fc m y) = do tag 14; toBuf fc; toBuf m; toBuf y - toBuf (Elaboratable_Bind_Name fc y) + toBuf (Elaborable_Bind_Name fc y) = do tag 15; toBuf fc; toBuf y - toBuf (Elaboratable_As_Pattern fc nameFC s y pattern) + toBuf (Elaborable_As_Pattern fc nameFC s y pattern) = do tag 16; toBuf fc; toBuf nameFC; toBuf s; toBuf y; toBuf pattern - toBuf (Elaboratable_Must_Unify fc r pattern) + toBuf (Elaborable_Must_Unify fc r pattern) -- No need to record 'r', it's for type errors only = do tag 17; toBuf fc; toBuf pattern - toBuf (Elaboratable_Delayed_Type fc r y) + toBuf (Elaborable_Delayed_Type fc r y) = do tag 18; toBuf fc; toBuf r; toBuf y - toBuf (Elaboratable_Delay fc t) + toBuf (Elaborable_Delay fc t) = do tag 19; toBuf fc; toBuf t - toBuf (Elaboratable_Force fc t) + toBuf (Elaborable_Force fc t) = do tag 20; toBuf fc; toBuf t - toBuf (Elaboratable_Quote fc t) + toBuf (Elaborable_Quote fc t) = do tag 21; toBuf fc; toBuf t - toBuf (Elaboratable_Quote_Name fc t) + toBuf (Elaborable_Quote_Name fc t) = do tag 22; toBuf fc; toBuf t - toBuf (Elaboratable_Quote_Declarations fc t) + toBuf (Elaborable_Quote_Declarations fc t) = do tag 23; toBuf fc; toBuf t - toBuf (Elaboratable_Unquote fc t) + toBuf (Elaborable_Unquote fc t) = do tag 24; toBuf fc; toBuf t - toBuf (Elaboratable_Run_Elaborator fc re t) + toBuf (Elaborable_Run_Elaborator fc re t) = do tag 25; toBuf fc; toBuf re; toBuf t - toBuf (Elaboratable_Primitive_Value fc y) + toBuf (Elaborable_Primitive_Value fc y) = do tag 26; toBuf fc; toBuf y - toBuf (Elaboratable_Type_Universe fc) + toBuf (Elaborable_Type_Universe fc) = do tag 27; toBuf fc - toBuf (Elaboratable_Hole fc y) + toBuf (Elaborable_Hole fc y) = do tag 28; toBuf fc; toBuf y - toBuf (Elaboratable_Unification_Log fc lvl x) = toBuf x + toBuf (Elaborable_Unification_Log fc lvl x) = toBuf x toBuf (Implicit fc i) = do tag 29; toBuf fc; toBuf i - toBuf (Elaboratable_With_Unambiguous_Names fc ns rhs) + toBuf (Elaborable_With_Unambiguous_Names fc ns rhs) = do tag 30; toBuf fc; toBuf ns; toBuf rhs - toBuf (Elaboratable_Automatic_Apply fc fn arg) + toBuf (Elaborable_Automatic_Apply fc fn arg) = do tag 31; toBuf fc; toBuf fn; toBuf arg fromBuf = case !getTag of 0 => do fc <- fromBuf; n <- fromBuf; - pure (Elaboratable_Name fc n) + pure (Elaborable_Name fc n) 1 => do fc <- fromBuf; r <- fromBuf; p <- fromBuf; n <- fromBuf argTy <- fromBuf; retTy <- fromBuf - pure (Elaboratable_Dependent_Function_Type fc r p n argTy retTy) + pure (Elaborable_Dependent_Function_Type fc r p n argTy retTy) 2 => do fc <- fromBuf; r <- fromBuf; p <- fromBuf; n <- fromBuf argTy <- fromBuf; scope <- fromBuf - pure (Elaboratable_Lambda fc r p n argTy scope) + pure (Elaborable_Lambda fc r p n argTy scope) 3 => do fc <- fromBuf; lhsFC <- fromBuf; r <- fromBuf; n <- fromBuf nTy <- fromBuf; nVal <- fromBuf scope <- fromBuf - pure (Elaboratable_Binding fc lhsFC r n nTy nVal scope) + pure (Elaborable_Binding fc lhsFC r n nTy nVal scope) 4 => do fc <- fromBuf; opts <- fromBuf; y <- fromBuf; ty <- fromBuf; xs <- fromBuf - pure (Elaboratable_Case fc opts y ty xs) + pure (Elaborable_Case fc opts y ty xs) 5 => do fc <- fromBuf; xs <- fromBuf; sc <- fromBuf - pure (Elaboratable_Local_Definitions fc xs sc) + pure (Elaborable_Local_Definitions fc xs sc) 6 => do fc <- fromBuf; fs <- fromBuf rec <- fromBuf - pure (Elaboratable_Record_Update fc fs rec) + pure (Elaborable_Record_Update fc fs rec) 7 => do fc <- fromBuf; fn <- fromBuf arg <- fromBuf - pure (Elaboratable_Apply fc fn arg) + pure (Elaborable_Apply fc fn arg) 8 => do fc <- fromBuf; fn <- fromBuf y <- fromBuf; arg <- fromBuf - pure (Elaboratable_Named_Apply fc fn y arg) + pure (Elaborable_Named_Apply fc fn y arg) 9 => do fc <- fromBuf; fn <- fromBuf arg <- fromBuf - pure (Elaboratable_With_Apply fc fn arg) + pure (Elaborable_With_Apply fc fn arg) 10 => do fc <- fromBuf; depth <- fromBuf - pure (Elaboratable_Search fc depth) + pure (Elaborable_Search fc depth) 11 => do fc <- fromBuf; y <- fromBuf xs <- fromBuf - pure (Elaboratable_Alternative fc y xs) + pure (Elaborable_Alternative fc y xs) 12 => do fc <- fromBuf; x <- fromBuf; y <- fromBuf - pure (Elaboratable_Rewrite fc x y) + pure (Elaborable_Rewrite fc x y) 13 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Coerced fc y) + pure (Elaborable_Coerced fc y) 14 => do fc <- fromBuf; m <- fromBuf; y <- fromBuf - pure (Elaboratable_Bind_Here fc m y) + pure (Elaborable_Bind_Here fc m y) 15 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Bind_Name fc y) + pure (Elaborable_Bind_Name fc y) 16 => do fc <- fromBuf; nameFC <- fromBuf side <- fromBuf; y <- fromBuf; pattern <- fromBuf - pure (Elaboratable_As_Pattern fc nameFC side y pattern) + pure (Elaborable_As_Pattern fc nameFC side y pattern) 17 => do fc <- fromBuf pattern <- fromBuf - pure (Elaboratable_Must_Unify fc UnknownDot pattern) + pure (Elaborable_Must_Unify fc UnknownDot pattern) 18 => do fc <- fromBuf; r <- fromBuf y <- fromBuf - pure (Elaboratable_Delayed_Type fc r y) + pure (Elaborable_Delayed_Type fc r y) 19 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Delay fc y) + pure (Elaborable_Delay fc y) 20 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Force fc y) + pure (Elaborable_Force fc y) 21 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Quote fc y) + pure (Elaborable_Quote fc y) 22 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Quote_Name fc y) + pure (Elaborable_Quote_Name fc y) 23 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Quote_Declarations fc y) + pure (Elaborable_Quote_Declarations fc y) 24 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Unquote fc y) + pure (Elaborable_Unquote fc y) 25 => do fc <- fromBuf; re <- fromBuf; y <- fromBuf - pure (Elaboratable_Run_Elaborator fc re y) + pure (Elaborable_Run_Elaborator fc re y) 26 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Primitive_Value fc y) + pure (Elaborable_Primitive_Value fc y) 27 => do fc <- fromBuf - pure (Elaboratable_Type_Universe fc) + pure (Elaborable_Type_Universe fc) 28 => do fc <- fromBuf; y <- fromBuf - pure (Elaboratable_Hole fc y) + pure (Elaborable_Hole fc y) 29 => do fc <- fromBuf i <- fromBuf pure (Implicit fc i) 30 => do fc <- fromBuf ns <- fromBuf rhs <- fromBuf - pure (Elaboratable_With_Unambiguous_Names fc ns rhs) + pure (Elaborable_With_Unambiguous_Names fc ns rhs) 31 => do fc <- fromBuf; fn <- fromBuf arg <- fromBuf - pure (Elaboratable_Automatic_Apply fc fn arg) + pure (Elaborable_Automatic_Apply fc fn arg) _ => corrupt "RawImp" export - TTC Elaboratable_Field_Update where - toBuf (Elaboratable_Set_Field p val) + TTC Elaborable_Field_Update where + toBuf (Elaborable_Set_Field p val) = do tag 0; toBuf p; toBuf val - toBuf (Elaboratable_Apply_To_Field p val) + toBuf (Elaborable_Apply_To_Field p val) = do tag 1; toBuf p; toBuf val fromBuf = case !getTag of 0 => do p <- fromBuf; val <- fromBuf - pure (Elaboratable_Set_Field p val) + pure (Elaborable_Set_Field p val) 1 => do p <- fromBuf; val <- fromBuf - pure (Elaboratable_Apply_To_Field p val) + pure (Elaborable_Apply_To_Field p val) _ => corrupt "IFieldUpdate" export @@ -349,71 +349,71 @@ mutual _ => corrupt "FnOpt" export - TTC (Elaboratable_Claim_Data Name) where - toBuf (Make_Elaboratable_Claim_Data rig vis opts type) + TTC (Elaborable_Claim_Data Name) where + toBuf (Make_Elaborable_Claim_Data rig vis opts type) = do toBuf rig; toBuf vis; toBuf opts; toBuf type fromBuf = do rig <- fromBuf vis <- fromBuf opts <- fromBuf type <- fromBuf - pure $ Make_Elaboratable_Claim_Data rig vis opts type + pure $ Make_Elaborable_Claim_Data rig vis opts type export TTC ImpDecl where - toBuf (Elaboratable_Claim claim) + toBuf (Elaborable_Claim claim) = do tag 0; toBuf claim - toBuf (Elaboratable_Data_Declaration fc vis mbtot d) + toBuf (Elaborable_Data_Declaration fc vis mbtot d) = do tag 1; toBuf fc; toBuf vis; toBuf mbtot; toBuf d - toBuf (Elaboratable_Definition fc n xs) + toBuf (Elaborable_Definition fc n xs) = do tag 2; toBuf fc; toBuf n; toBuf xs - toBuf (Elaboratable_Parameter_Block fc vis d) + toBuf (Elaborable_Parameter_Block fc vis d) = do tag 3; toBuf fc; toBuf vis; toBuf d - toBuf (Elaboratable_Record_Declaration fc ns vis mbtot r) + toBuf (Elaborable_Record_Declaration fc ns vis mbtot r) = do tag 4; toBuf fc; toBuf ns; toBuf vis; toBuf mbtot; toBuf r - toBuf (Elaboratable_Namespace_Block fc xs ds) + toBuf (Elaborable_Namespace_Block fc xs ds) = do tag 5; toBuf fc; toBuf xs; toBuf ds - toBuf (Elaboratable_Transformation fc n lhs rhs) + toBuf (Elaborable_Transformation fc n lhs rhs) = do tag 6; toBuf fc; toBuf n; toBuf lhs; toBuf rhs - toBuf (Elaboratable_Run_Elaborator_Declaration fc tm) + toBuf (Elaborable_Run_Elaborator_Declaration fc tm) = do tag 7; toBuf fc; toBuf tm - toBuf (Elaboratable_Pragma _ _ f) = throw (InternalError "Can't write Pragma") - toBuf (Elaboratable_Logging n) + toBuf (Elaborable_Pragma _ _ f) = throw (InternalError "Can't write Pragma") + toBuf (Elaborable_Logging n) = do tag 8; toBuf n - toBuf (Elaboratable_Builtin_Declaration fc type name) + toBuf (Elaborable_Builtin_Declaration fc type name) = do tag 9; toBuf fc; toBuf type; toBuf name - toBuf (Elaboratable_Expected_Failure {}) + toBuf (Elaborable_Expected_Failure {}) = pure () fromBuf = case !getTag of 0 => do claimData <- fromBuf - pure (Elaboratable_Claim claimData) + pure (Elaborable_Claim claimData) 1 => do fc <- fromBuf; vis <- fromBuf mbtot <- fromBuf; d <- fromBuf - pure (Elaboratable_Data_Declaration fc vis mbtot d) + pure (Elaborable_Data_Declaration fc vis mbtot d) 2 => do fc <- fromBuf; n <- fromBuf xs <- fromBuf - pure (Elaboratable_Definition fc n xs) + pure (Elaborable_Definition fc n xs) 3 => do fc <- fromBuf; vis <- fromBuf d <- fromBuf - pure (Elaboratable_Parameter_Block fc vis d) + pure (Elaborable_Parameter_Block fc vis d) 4 => do fc <- fromBuf; ns <- fromBuf; vis <- fromBuf; mbtot <- fromBuf; r <- fromBuf - pure (Elaboratable_Record_Declaration fc ns vis mbtot r) + pure (Elaborable_Record_Declaration fc ns vis mbtot r) 5 => do fc <- fromBuf; xs <- fromBuf ds <- fromBuf - pure (Elaboratable_Namespace_Block fc xs ds) + pure (Elaborable_Namespace_Block fc xs ds) 6 => do fc <- fromBuf; n <- fromBuf lhs <- fromBuf; rhs <- fromBuf - pure (Elaboratable_Transformation fc n lhs rhs) + pure (Elaborable_Transformation fc n lhs rhs) 7 => do fc <- fromBuf; tm <- fromBuf - pure (Elaboratable_Run_Elaborator_Declaration fc tm) + pure (Elaborable_Run_Elaborator_Declaration fc tm) 8 => do n <- fromBuf - pure (Elaboratable_Logging n) + pure (Elaborable_Logging n) 9 => do fc <- fromBuf type <- fromBuf name <- fromBuf - pure (Elaboratable_Builtin_Declaration fc type name) + pure (Elaborable_Builtin_Declaration fc type name) _ => corrupt "ImpDecl" diff --git a/TTImp/TTImp/Traversals.idr b/TTImp/TTImp/Traversals.idr index 97f67e7308..88b65c3e0f 100644 --- a/TTImp/TTImp/Traversals.idr +++ b/TTImp/TTImp/Traversals.idr @@ -56,24 +56,24 @@ parameters (f : RawImp' nm -> RawImp' nm) export mapImpDecl : ImpDecl' nm -> ImpDecl' nm - mapImpDecl (Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data rig vis opts ty))) - = Elaboratable_Claim (MkWithData fc (Make_Elaboratable_Claim_Data rig vis (map mapFnOpt opts) (map mapTTImp ty))) - mapImpDecl (Elaboratable_Data_Declaration fc vis mtreq dat) = Elaboratable_Data_Declaration fc vis mtreq (mapImpData dat) - mapImpDecl (Elaboratable_Definition fc n cls) = Elaboratable_Definition fc n (map mapImpClause cls) - mapImpDecl (Elaboratable_Parameter_Block fc params xs) = Elaboratable_Parameter_Block fc params (assert_total $ map mapImpDecl xs) - mapImpDecl (Elaboratable_Record_Declaration fc mstr x y rec) = Elaboratable_Record_Declaration fc mstr x y (map mapImpRecord rec) - mapImpDecl (Elaboratable_Expected_Failure fc mstr xs) = Elaboratable_Expected_Failure fc mstr (assert_total $ map mapImpDecl xs) - mapImpDecl (Elaboratable_Namespace_Block fc mi xs) = Elaboratable_Namespace_Block fc mi (assert_total $ map mapImpDecl xs) - mapImpDecl (Elaboratable_Transformation fc n t u) = Elaboratable_Transformation fc n (mapTTImp t) (mapTTImp u) - mapImpDecl (Elaboratable_Run_Elaborator_Declaration fc t) = Elaboratable_Run_Elaborator_Declaration fc (mapTTImp t) - mapImpDecl (Elaboratable_Pragma fc ns g) = Elaboratable_Pragma fc ns g - mapImpDecl (Elaboratable_Logging x) = Elaboratable_Logging x - mapImpDecl (Elaboratable_Builtin_Declaration fc x n) = Elaboratable_Builtin_Declaration fc x n + mapImpDecl (Elaborable_Claim (MkWithData fc (Make_Elaborable_Claim_Data rig vis opts ty))) + = Elaborable_Claim (MkWithData fc (Make_Elaborable_Claim_Data rig vis (map mapFnOpt opts) (map mapTTImp ty))) + mapImpDecl (Elaborable_Data_Declaration fc vis mtreq dat) = Elaborable_Data_Declaration fc vis mtreq (mapImpData dat) + mapImpDecl (Elaborable_Definition fc n cls) = Elaborable_Definition fc n (map mapImpClause cls) + mapImpDecl (Elaborable_Parameter_Block fc params xs) = Elaborable_Parameter_Block fc params (assert_total $ map mapImpDecl xs) + mapImpDecl (Elaborable_Record_Declaration fc mstr x y rec) = Elaborable_Record_Declaration fc mstr x y (map mapImpRecord rec) + mapImpDecl (Elaborable_Expected_Failure fc mstr xs) = Elaborable_Expected_Failure fc mstr (assert_total $ map mapImpDecl xs) + mapImpDecl (Elaborable_Namespace_Block fc mi xs) = Elaborable_Namespace_Block fc mi (assert_total $ map mapImpDecl xs) + mapImpDecl (Elaborable_Transformation fc n t u) = Elaborable_Transformation fc n (mapTTImp t) (mapTTImp u) + mapImpDecl (Elaborable_Run_Elaborator_Declaration fc t) = Elaborable_Run_Elaborator_Declaration fc (mapTTImp t) + mapImpDecl (Elaborable_Pragma fc ns g) = Elaborable_Pragma fc ns g + mapImpDecl (Elaborable_Logging x) = Elaborable_Logging x + mapImpDecl (Elaborable_Builtin_Declaration fc x n) = Elaborable_Builtin_Declaration fc x n export - mapIFieldUpdate : Elaboratable_Field_Update' nm -> Elaboratable_Field_Update' nm - mapIFieldUpdate (Elaboratable_Set_Field path t) = Elaboratable_Set_Field path (mapTTImp t) - mapIFieldUpdate (Elaboratable_Apply_To_Field path t) = Elaboratable_Apply_To_Field path (mapTTImp t) + mapIFieldUpdate : Elaborable_Field_Update' nm -> Elaborable_Field_Update' nm + mapIFieldUpdate (Elaborable_Set_Field path t) = Elaborable_Set_Field path (mapTTImp t) + mapIFieldUpdate (Elaborable_Apply_To_Field path t) = Elaborable_Apply_To_Field path (mapTTImp t) export mapAltType : AltType' nm -> AltType' nm @@ -81,42 +81,42 @@ parameters (f : RawImp' nm -> RawImp' nm) mapAltType Unique = Unique mapAltType (UniqueDefault t) = UniqueDefault (mapTTImp t) - mapTTImp t@(Elaboratable_Name {}) = f t - mapTTImp (Elaboratable_Dependent_Function_Type fc rig pinfo x argTy retTy) - = f $ Elaboratable_Dependent_Function_Type fc rig (mapPiInfo pinfo) x (mapTTImp argTy) (mapTTImp retTy) - mapTTImp (Elaboratable_Lambda fc rig pinfo x argTy lamTy) - = f $ Elaboratable_Lambda fc rig (mapPiInfo pinfo) x (mapTTImp argTy) (mapTTImp lamTy) - mapTTImp (Elaboratable_Binding fc lhsFC rig n nTy nVal scope) - = f $ Elaboratable_Binding fc lhsFC rig n (mapTTImp nTy) (mapTTImp nVal) (mapTTImp scope) - mapTTImp (Elaboratable_Case fc opts t ty cls) - = f $ Elaboratable_Case fc opts (mapTTImp t) (mapTTImp ty) (assert_total $ map mapImpClause cls) - mapTTImp (Elaboratable_Local_Definitions fc xs t) - = f $ Elaboratable_Local_Definitions fc (assert_total $ map mapImpDecl xs) (mapTTImp t) - mapTTImp (Elaboratable_Case_Local_Definition fc unm inm args t) = f $ Elaboratable_Case_Local_Definition fc unm inm args (mapTTImp t) - mapTTImp (Elaboratable_Record_Update fc upds t) = f $ Elaboratable_Record_Update fc (assert_total map mapIFieldUpdate upds) (mapTTImp t) - mapTTImp (Elaboratable_Apply fc t u) = f $ Elaboratable_Apply fc (mapTTImp t) (mapTTImp u) - mapTTImp (Elaboratable_Automatic_Apply fc t u) = f $ Elaboratable_Automatic_Apply fc (mapTTImp t) (mapTTImp u) - mapTTImp (Elaboratable_Named_Apply fc t n u) = f $ Elaboratable_Named_Apply fc (mapTTImp t) n (mapTTImp u) - mapTTImp (Elaboratable_With_Apply fc t u) = f $ Elaboratable_With_Apply fc (mapTTImp t) (mapTTImp u) - mapTTImp (Elaboratable_Search fc depth) = f $ Elaboratable_Search fc depth - mapTTImp (Elaboratable_Alternative fc alt ts) = f $ Elaboratable_Alternative fc (mapAltType alt) (assert_total map mapTTImp ts) - mapTTImp (Elaboratable_Rewrite fc t u) = f $ Elaboratable_Rewrite fc (mapTTImp t) (mapTTImp u) - mapTTImp (Elaboratable_Coerced fc t) = f $ Elaboratable_Coerced fc (mapTTImp t) - mapTTImp (Elaboratable_Bind_Here fc bm t) = f $ Elaboratable_Bind_Here fc bm (mapTTImp t) - mapTTImp (Elaboratable_Bind_Name fc str) = f $ Elaboratable_Bind_Name fc str - mapTTImp (Elaboratable_As_Pattern fc nameFC side n t) = f $ Elaboratable_As_Pattern fc nameFC side n (mapTTImp t) - mapTTImp (Elaboratable_Must_Unify fc x t) = f $ Elaboratable_Must_Unify fc x (mapTTImp t) - mapTTImp (Elaboratable_Delayed_Type fc lz t) = f $ Elaboratable_Delayed_Type fc lz (mapTTImp t) - mapTTImp (Elaboratable_Delay fc t) = f $ Elaboratable_Delay fc (mapTTImp t) - mapTTImp (Elaboratable_Force fc t) = f $ Elaboratable_Force fc (mapTTImp t) - mapTTImp (Elaboratable_Quote fc t) = f $ Elaboratable_Quote fc (mapTTImp t) - mapTTImp (Elaboratable_Quote_Name fc n) = f $ Elaboratable_Quote_Name fc n - mapTTImp (Elaboratable_Quote_Declarations fc xs) = f $ Elaboratable_Quote_Declarations fc (assert_total $ map mapImpDecl xs) - mapTTImp (Elaboratable_Unquote fc t) = f $ Elaboratable_Unquote fc (mapTTImp t) - mapTTImp (Elaboratable_Run_Elaborator fc re t) = f $ Elaboratable_Run_Elaborator fc re (mapTTImp t) - mapTTImp (Elaboratable_Primitive_Value fc c) = f $ Elaboratable_Primitive_Value fc c - mapTTImp (Elaboratable_Type_Universe fc) = f $ Elaboratable_Type_Universe fc - mapTTImp (Elaboratable_Hole fc str) = f $ Elaboratable_Hole fc str - mapTTImp (Elaboratable_Unification_Log fc x t) = f $ Elaboratable_Unification_Log fc x (mapTTImp t) + mapTTImp t@(Elaborable_Name {}) = f t + mapTTImp (Elaborable_Dependent_Function_Type fc rig pinfo x argTy retTy) + = f $ Elaborable_Dependent_Function_Type fc rig (mapPiInfo pinfo) x (mapTTImp argTy) (mapTTImp retTy) + mapTTImp (Elaborable_Lambda fc rig pinfo x argTy lamTy) + = f $ Elaborable_Lambda fc rig (mapPiInfo pinfo) x (mapTTImp argTy) (mapTTImp lamTy) + mapTTImp (Elaborable_Binding fc lhsFC rig n nTy nVal scope) + = f $ Elaborable_Binding fc lhsFC rig n (mapTTImp nTy) (mapTTImp nVal) (mapTTImp scope) + mapTTImp (Elaborable_Case fc opts t ty cls) + = f $ Elaborable_Case fc opts (mapTTImp t) (mapTTImp ty) (assert_total $ map mapImpClause cls) + mapTTImp (Elaborable_Local_Definitions fc xs t) + = f $ Elaborable_Local_Definitions fc (assert_total $ map mapImpDecl xs) (mapTTImp t) + mapTTImp (Elaborable_Case_Local_Definition fc unm inm args t) = f $ Elaborable_Case_Local_Definition fc unm inm args (mapTTImp t) + mapTTImp (Elaborable_Record_Update fc upds t) = f $ Elaborable_Record_Update fc (assert_total map mapIFieldUpdate upds) (mapTTImp t) + mapTTImp (Elaborable_Apply fc t u) = f $ Elaborable_Apply fc (mapTTImp t) (mapTTImp u) + mapTTImp (Elaborable_Automatic_Apply fc t u) = f $ Elaborable_Automatic_Apply fc (mapTTImp t) (mapTTImp u) + mapTTImp (Elaborable_Named_Apply fc t n u) = f $ Elaborable_Named_Apply fc (mapTTImp t) n (mapTTImp u) + mapTTImp (Elaborable_With_Apply fc t u) = f $ Elaborable_With_Apply fc (mapTTImp t) (mapTTImp u) + mapTTImp (Elaborable_Search fc depth) = f $ Elaborable_Search fc depth + mapTTImp (Elaborable_Alternative fc alt ts) = f $ Elaborable_Alternative fc (mapAltType alt) (assert_total map mapTTImp ts) + mapTTImp (Elaborable_Rewrite fc t u) = f $ Elaborable_Rewrite fc (mapTTImp t) (mapTTImp u) + mapTTImp (Elaborable_Coerced fc t) = f $ Elaborable_Coerced fc (mapTTImp t) + mapTTImp (Elaborable_Bind_Here fc bm t) = f $ Elaborable_Bind_Here fc bm (mapTTImp t) + mapTTImp (Elaborable_Bind_Name fc str) = f $ Elaborable_Bind_Name fc str + mapTTImp (Elaborable_As_Pattern fc nameFC side n t) = f $ Elaborable_As_Pattern fc nameFC side n (mapTTImp t) + mapTTImp (Elaborable_Must_Unify fc x t) = f $ Elaborable_Must_Unify fc x (mapTTImp t) + mapTTImp (Elaborable_Delayed_Type fc lz t) = f $ Elaborable_Delayed_Type fc lz (mapTTImp t) + mapTTImp (Elaborable_Delay fc t) = f $ Elaborable_Delay fc (mapTTImp t) + mapTTImp (Elaborable_Force fc t) = f $ Elaborable_Force fc (mapTTImp t) + mapTTImp (Elaborable_Quote fc t) = f $ Elaborable_Quote fc (mapTTImp t) + mapTTImp (Elaborable_Quote_Name fc n) = f $ Elaborable_Quote_Name fc n + mapTTImp (Elaborable_Quote_Declarations fc xs) = f $ Elaborable_Quote_Declarations fc (assert_total $ map mapImpDecl xs) + mapTTImp (Elaborable_Unquote fc t) = f $ Elaborable_Unquote fc (mapTTImp t) + mapTTImp (Elaborable_Run_Elaborator fc re t) = f $ Elaborable_Run_Elaborator fc re (mapTTImp t) + mapTTImp (Elaborable_Primitive_Value fc c) = f $ Elaborable_Primitive_Value fc c + mapTTImp (Elaborable_Type_Universe fc) = f $ Elaborable_Type_Universe fc + mapTTImp (Elaborable_Hole fc str) = f $ Elaborable_Hole fc str + mapTTImp (Elaborable_Unification_Log fc x t) = f $ Elaborable_Unification_Log fc x (mapTTImp t) mapTTImp (Implicit fc bindIfUnsolved) = f $ Implicit fc bindIfUnsolved - mapTTImp (Elaboratable_With_Unambiguous_Names fc xs t) = f $ Elaboratable_With_Unambiguous_Names fc xs (mapTTImp t) + mapTTImp (Elaborable_With_Unambiguous_Names fc xs t) = f $ Elaborable_With_Unambiguous_Names fc xs (mapTTImp t) diff --git a/TTImp/Unelab.idr b/TTImp/Unelab.idr index da2193c61e..0e652c4245 100644 --- a/TTImp/Unelab.idr +++ b/TTImp/Unelab.idr @@ -71,7 +71,7 @@ mutual Env Term vars -> Name -> List (Term vars) -> - Core (Maybe Kinded_Elaboratable_Term) + Core (Maybe Kinded_Elaborable_Term) unelabCase nest env n args = do defs <- get Ctxt Just glob <- lookupCtxtExact n (gamma defs) @@ -128,7 +128,7 @@ mutual mkClause : FC -> Nat -> List (Term vars) -> (vs ** (Env Term vs, Term vs, Term vs)) -> - Core (Maybe Kinded_Elaboratable_Clause) + Core (Maybe Kinded_Elaborable_Clause) mkClause fc argpos args (vs ** (clauseEnv, lhs, rhs)) = do logTerm "unelab.case.clause" 20 "Unelaborating clause" lhs let patArgs = snd (getFnArgs lhs) @@ -149,7 +149,7 @@ mutual ||| Once we have the scrutinee `e`, we can form `case e of` and so focus ||| on manufacturing the clauses. mkCase : List (vs ** (Env Term vs, Term vs, Term vs)) -> - (argpos : Nat) -> List (Term vars) -> Core (Maybe Kinded_Elaboratable_Term) + (argpos : Nat) -> List (Term vars) -> Core (Maybe Kinded_Elaborable_Term) mkCase pats argpos args = do unless (null args) $ log "unelab.case.clause" 20 $ unwords $ "Ignoring" :: map show args @@ -160,23 +160,23 @@ mutual Just pats' <- map sequence $ traverse (mkClause fc argpos args) pats | _ => pure Nothing -- TODO: actually grab the fnopts? - pure $ Just $ Elaboratable_Case fc [] tm (Implicit fc False) pats' + pure $ Just $ Elaborable_Case fc [] tm (Implicit fc False) pats' - dropParams : List (Name, Nat) -> (Kinded_Elaboratable_Term, Glued vars) -> - Core (Kinded_Elaboratable_Term, Glued vars) + dropParams : List (Name, Nat) -> (Kinded_Elaborable_Term, Glued vars) -> + Core (Kinded_Elaborable_Term, Glued vars) dropParams nest (tm, ty) = case getFnArgs tm [] of - (Elaboratable_Name fc n, args) => + (Elaborable_Name fc n, args) => case lookup (rawName n) nest of Nothing => pure (tm, ty) - Just i => pure $ (apply (Elaboratable_Name fc n) (drop i args), ty) + Just i => pure $ (apply (Elaborable_Name fc n) (drop i args), ty) _ => pure (tm, ty) where - apply : Kinded_Elaboratable_Term -> List Kinded_Elaboratable_Argument -> Kinded_Elaboratable_Term + apply : Kinded_Elaborable_Term -> List Kinded_Elaborable_Argument -> Kinded_Elaborable_Term apply tm [] = tm - apply tm (Explicit fc a :: args) = apply (Elaboratable_Apply fc tm a) args - apply tm (Auto fc a :: args) = apply (Elaboratable_Automatic_Apply fc tm a) args - apply tm (Named fc n a :: args) = apply (Elaboratable_Named_Apply fc tm n a) args + apply tm (Explicit fc a :: args) = apply (Elaborable_Apply fc tm a) args + apply tm (Auto fc a :: args) = apply (Elaborable_Automatic_Apply fc tm a) args + apply tm (Named fc n a :: args) = apply (Elaborable_Named_Apply fc tm n a) args -- Turn a term back into an unannotated TTImp. Returns the type of the -- unelaborated term so that we can work out where to put the implicit @@ -188,7 +188,7 @@ mutual (umode : UnelabMode) -> (nest : List (Name, Nat)) -> Env Term vars -> Term vars -> - Core (Kinded_Elaboratable_Term, Glued vars) + Core (Kinded_Elaborable_Term, Glued vars) unelabTy umode nest env tm = dropParams nest !(unelabTy' umode nest env tm) @@ -197,18 +197,18 @@ mutual (umode : UnelabMode) -> (nest : List (Name, Nat)) -> Env Term vars -> Term vars -> - Core (Kinded_Elaboratable_Term, Glued vars) + Core (Kinded_Elaborable_Term, Glued vars) unelabTy' umode nest env (Local fc _ idx p) = do let nm = nameAt p log "unelab.case" 20 $ "Found local name: " ++ show nm let ty = gnf env (binderType (getBinder p env)) - pure (Elaboratable_Name fc (MkKindedName (Just Bound) nm nm), ty) + pure (Elaborable_Name fc (MkKindedName (Just Bound) nm nm), ty) unelabTy' umode nest env (Ref fc nt n) = do defs <- get Ctxt Just ty <- lookupTyExact n (gamma defs) | Nothing => case umode of ImplicitHoles => pure (Implicit fc True, gErased fc) - _ => pure (Elaboratable_Name fc (MkKindedName (Just nt) n n), gErased fc) + _ => pure (Elaborable_Name fc (MkKindedName (Just nt) n n), gErased fc) fn <- getFullName n n' <- case umode of NoSugar _ => pure fn @@ -219,14 +219,14 @@ mutual , "sugared to", show n' ] - pure (Elaboratable_Name fc (MkKindedName (Just nt) fn n'), gnf env (embed ty)) + pure (Elaborable_Name fc (MkKindedName (Just nt) fn n'), gnf env (embed ty)) unelabTy' umode nest env (Meta fc n i args) = do defs <- get Ctxt let mkn = nameRoot n def <- lookupDefExact (Resolved i) (gamma defs) let term = case def of - (Just (BySearch _ d _)) => Elaboratable_Search fc d - _ => Elaboratable_Hole fc mkn + (Just (BySearch _ d _)) => Elaborable_Search fc d + _ => Elaborable_Hole fc mkn Just ty <- lookupTyExact (Resolved i) (gamma defs) | Nothing => case umode of ImplicitHoles => pure (Implicit fc True, gErased fc) @@ -276,46 +276,46 @@ mutual case fnty of NBind _ x (Pi _ rig Explicit ty) sc => do sc' <- sc defs (toClosure defaultOpts env arg) - pure (Elaboratable_Apply fc fn' arg', + pure (Elaborable_Apply fc fn' arg', glueBack defs env sc') NBind _ x (Pi _ rig p ty) sc => do sc' <- sc defs (toClosure defaultOpts env arg) - pure (Elaboratable_Named_Apply fc fn' x arg', + pure (Elaborable_Named_Apply fc fn' x arg', glueBack defs env sc') - _ => pure (Elaboratable_Apply fc fn' arg', gErased fc) + _ => pure (Elaborable_Apply fc fn' arg', gErased fc) unelabTy' umode nest env (As fc s p tm) = do (p', _) <- unelabTy' umode nest env p (tm', ty) <- unelabTy' umode nest env tm case p' of - Elaboratable_Name _ n => + Elaborable_Name _ n => case umode of - NoSugar _ => pure (Elaboratable_As_Pattern fc (getLoc p) s n.rawName tm', ty) + NoSugar _ => pure (Elaborable_As_Pattern fc (getLoc p) s n.rawName tm', ty) _ => pure (tm', ty) _ => pure (tm', ty) -- Should never happen! unelabTy' umode nest env (TDelayed fc r tm) = do (tm', ty) <- unelabTy' umode nest env tm defs <- get Ctxt - pure (Elaboratable_Delayed_Type fc r tm', gErased fc) + pure (Elaborable_Delayed_Type fc r tm', gErased fc) unelabTy' umode nest env (TDelay fc r _ tm) = do (tm', ty) <- unelabTy' umode nest env tm defs <- get Ctxt - pure (Elaboratable_Delay fc tm', gErased fc) + pure (Elaborable_Delay fc tm', gErased fc) unelabTy' umode nest env (TForce fc r tm) = do (tm', ty) <- unelabTy' umode nest env tm defs <- get Ctxt - pure (Elaboratable_Force fc tm', gErased fc) - unelabTy' umode nest env (PrimVal fc c) = pure (Elaboratable_Primitive_Value fc c, gErased fc) + pure (Elaborable_Force fc tm', gErased fc) + unelabTy' umode nest env (PrimVal fc c) = pure (Elaborable_Primitive_Value fc c, gErased fc) unelabTy' umode nest env (Erased fc (Dotted t)) = unelabTy' umode nest env t unelabTy' umode nest env (Erased fc _) = pure (Implicit fc True, gErased fc) - unelabTy' umode nest env (TType fc _) = pure (Elaboratable_Type_Universe fc, gType fc (MN "top" 0)) + unelabTy' umode nest env (TType fc _) = pure (Elaborable_Type_Universe fc, gType fc (MN "top" 0)) unelabPi : {vars : _} -> {auto c : Ref Ctxt Defs} -> (umode : UnelabMode) -> (nest : List (Name, Nat)) -> Env Term vars -> PiInfo (Term vars) -> - Core (PiInfo Kinded_Elaboratable_Term) + Core (PiInfo Kinded_Elaborable_Term) unelabPi umode nest env Explicit = pure Explicit unelabPi umode nest env Implicit = pure Implicit unelabPi umode nest env AutoImplicit = pure AutoImplicit @@ -329,17 +329,17 @@ mutual (nest : List (Name, Nat)) -> FC -> Env Term vars -> (x : Name) -> Binder (Term vars) -> Term (x :: vars) -> - Kinded_Elaboratable_Term -> Term (x :: vars) -> - Core (Kinded_Elaboratable_Term, Glued vars) + Kinded_Elaborable_Term -> Term (x :: vars) -> + Core (Kinded_Elaborable_Term, Glued vars) unelabBinder umode nest fc env x (Lam fc' rig p ty) sctm sc scty = do (ty', _) <- unelabTy umode nest env ty p' <- unelabPi umode nest env p - pure (Elaboratable_Lambda fc rig p' (Just x) ty' sc, + pure (Elaborable_Lambda fc rig p' (Just x) ty' sc, gnf env (Bind fc x (Pi fc' rig p ty) scty)) unelabBinder umode nest fc env x (Let fc' rig val ty) sctm sc scty = do (val', vty) <- unelabTy umode nest env val (ty', _) <- unelabTy umode nest env ty - pure (Elaboratable_Binding fc EmptyFC rig x ty' val' sc, + pure (Elaborable_Binding fc EmptyFC rig x ty' val' sc, gnf env (Bind fc x (Let fc' rig val ty) scty)) unelabBinder umode nest fc env x (Pi _ rig p ty) sctm sc scty = do (ty', _) <- unelabTy umode nest env ty @@ -349,7 +349,7 @@ mutual else if rig /= top || isDefImp p then Just (UN Underscore) else Nothing - pure (Elaboratable_Dependent_Function_Type fc rig p' nm ty' sc, gType fc (MN "top" 0)) + pure (Elaborable_Dependent_Function_Type fc rig p' nm ty' sc, gType fc (MN "top" 0)) where isNoSugar : UnelabMode -> Bool isNoSugar (NoSugar _) = True @@ -363,7 +363,7 @@ mutual unelabBinder umode nest fc env x (PLet fc' rig val ty) sctm sc scty = do (val', vty) <- unelabTy umode nest env val (ty', _) <- unelabTy umode nest env ty - pure (Elaboratable_Binding fc EmptyFC rig x ty' val' sc, + pure (Elaborable_Binding fc EmptyFC rig x ty' val' sc, gnf env (Bind fc x (PLet fc' rig val ty) scty)) unelabBinder umode nest fc env x (PVTy _ rig ty) sctm sc scty = do (ty', _) <- unelabTy umode nest env ty @@ -372,7 +372,7 @@ mutual export unelabNoSugar : {vars : _} -> {auto c : Ref Ctxt Defs} -> - Env Term vars -> Term vars -> Core Kinded_Elaboratable_Term + Env Term vars -> Term vars -> Core Kinded_Elaborable_Term unelabNoSugar env tm = do tm' <- unelabTy (NoSugar False) [] env tm pure $ fst tm' @@ -380,7 +380,7 @@ unelabNoSugar env tm export unelabUniqueBinders : {vars : _} -> {auto c : Ref Ctxt Defs} -> - Env Term vars -> Term vars -> Core Kinded_Elaboratable_Term + Env Term vars -> Term vars -> Core Kinded_Elaborable_Term unelabUniqueBinders env tm = do tm' <- unelabTy (NoSugar True) [] env tm pure $ fst tm' @@ -388,7 +388,7 @@ unelabUniqueBinders env tm export unelabNoPatvars : {vars : _} -> {auto c : Ref Ctxt Defs} -> - Env Term vars -> Term vars -> Core Kinded_Elaboratable_Term + Env Term vars -> Term vars -> Core Kinded_Elaborable_Term unelabNoPatvars env tm = do tm' <- unelabTy ImplicitHoles [] env tm pure $ fst tm' @@ -399,10 +399,10 @@ unelabNest : {vars : _} -> UnelabMode -> List (Name, Nat) -> Env Term vars -> - Term vars -> Core Kinded_Elaboratable_Term + Term vars -> Core Kinded_Elaborable_Term unelabNest mode nest env (Meta fc n i args) = do let mkn = nameRoot n ++ showScope args - pure (Elaboratable_Hole fc mkn) + pure (Elaborable_Hole fc mkn) where toName : Term vars -> Maybe Name toName (Local _ _ idx p) = Just (nameAt p) @@ -423,5 +423,5 @@ export unelab : {vars : _} -> {auto c : Ref Ctxt Defs} -> Env Term vars -> - Term vars -> Core Kinded_Elaboratable_Term + Term vars -> Core Kinded_Elaborable_Term unelab = unelabNest Full [] diff --git a/TTImp/Utils.idr b/TTImp/Utils.idr index b8b39e8239..d8f36361b8 100644 --- a/TTImp/Utils.idr +++ b/TTImp/Utils.idr @@ -25,23 +25,23 @@ genUniqueStr xs x = if x `elem` xs then genUniqueStr xs (x ++ "'") else x -- Used in findBindableNames{,Quot} rawImpFromDecl : ImpDecl -> List RawImp rawImpFromDecl decl = case decl of - Elaboratable_Claim (MkWithData fc1 $ Make_Elaboratable_Claim_Data y z ys ty) => [ty.val] - Elaboratable_Data_Declaration fc1 y _ (MkImpData fc2 n tycon opts datacons) + Elaborable_Claim (MkWithData fc1 $ Make_Elaborable_Claim_Data y z ys ty) => [ty.val] + Elaborable_Data_Declaration fc1 y _ (MkImpData fc2 n tycon opts datacons) => maybe id (::) tycon $ map val datacons - Elaboratable_Data_Declaration fc1 y _ (MkImpLater fc2 n tycon) => [tycon] - Elaboratable_Definition fc1 y ys => getFromClause !ys - Elaboratable_Parameter_Block fc1 ys zs => rawImpFromDecl !zs ++ map getParamTy (forget ys) - Elaboratable_Record_Declaration fc1 y z _ (MkWithData _ (MkImpRecord header body)) => do + Elaborable_Data_Declaration fc1 y _ (MkImpLater fc2 n tycon) => [tycon] + Elaborable_Definition fc1 y ys => getFromClause !ys + Elaborable_Parameter_Block fc1 ys zs => rawImpFromDecl !zs ++ map getParamTy (forget ys) + Elaborable_Record_Declaration fc1 y z _ (MkWithData _ (MkImpRecord header body)) => do binder <- header.val field <- body.val getFromPiInfo binder.val.info ++ [binder.val.boundType] ++ getFromIField field - Elaboratable_Expected_Failure fc1 msg zs => rawImpFromDecl !zs - Elaboratable_Namespace_Block fc1 ys zs => rawImpFromDecl !zs - Elaboratable_Transformation fc1 y z w => [z, w] - Elaboratable_Run_Elaborator_Declaration fc1 y => [] -- Not sure about this either - Elaboratable_Pragma _ _ f => [] - Elaboratable_Logging k => [] - Elaboratable_Builtin_Declaration {} => [] + Elaborable_Expected_Failure fc1 msg zs => rawImpFromDecl !zs + Elaborable_Namespace_Block fc1 ys zs => rawImpFromDecl !zs + Elaborable_Transformation fc1 y z w => [z, w] + Elaborable_Run_Elaborator_Declaration fc1 y => [] -- Not sure about this either + Elaborable_Pragma _ _ f => [] + Elaborable_Logging k => [] + Elaborable_Builtin_Declaration {} => [] where getParamTy : ImpParameter' RawImp -> RawImp getParamTy binder = binder.val.boundType getFromClause : ImpClause -> List RawImp @@ -51,12 +51,12 @@ rawImpFromDecl decl = case decl of getFromPiInfo : PiInfo RawImp -> List RawImp getFromPiInfo (DefImplicit x) = [x] getFromPiInfo _ = [] - getFromIField : Elaboratable_Field -> List RawImp + getFromIField : Elaborable_Field -> List RawImp getFromIField field = getFromPiInfo field.val.info ++ [field.val.boundType] -- Identify lower case names in argument position, which we can bind later. --- Don't go under case, let, or local bindings, or Elaboratable_Alternative. +-- Don't go under case, let, or local bindings, or Elaborable_Alternative. -- -- arg: Is the current expression in argument position? (We don't want to implicitly -- bind funtions.) @@ -70,119 +70,119 @@ findBindableNames : (arg : Bool) -> (env : List Name) -> (used : List String) -> findBindableNamesQuot : List Name -> (used : List String) -> RawImp -> List (Name, Name) -findBindableNames True env used (Elaboratable_Name fc nm@(UN (Basic n))) +findBindableNames True env used (Elaborable_Name fc nm@(UN (Basic n))) -- If the identifier is not bound locally and begins with a lowercase letter.. = if not (nm `elem` env) && lowerFirst n then [(nm, UN $ Basic $ genUniqueStr used n)] else [] -findBindableNames arg env used (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) +findBindableNames arg env used (Elaborable_Dependent_Function_Type fc rig p mn aty retty) = let env' = case mn of Nothing => env Just n => n :: env in findBindableNames True env used aty ++ findBindableNames True env' used retty -findBindableNames arg env used (Elaboratable_Lambda fc rig p mn aty sc) +findBindableNames arg env used (Elaborable_Lambda fc rig p mn aty sc) = let env' = case mn of Nothing => env Just n => n :: env in findBindableNames True env used aty ++ findBindableNames True env' used sc -findBindableNames arg env used (Elaboratable_Apply fc fn av) +findBindableNames arg env used (Elaborable_Apply fc fn av) = findBindableNames False env used fn ++ findBindableNames True env used av -findBindableNames arg env used (Elaboratable_Named_Apply fc fn n av) +findBindableNames arg env used (Elaborable_Named_Apply fc fn n av) = findBindableNames False env used fn ++ findBindableNames True env used av -findBindableNames arg env used (Elaboratable_Automatic_Apply fc fn av) +findBindableNames arg env used (Elaborable_Automatic_Apply fc fn av) = findBindableNames False env used fn ++ findBindableNames True env used av -findBindableNames arg env used (Elaboratable_With_Apply fc fn av) +findBindableNames arg env used (Elaborable_With_Apply fc fn av) = findBindableNames False env used fn ++ findBindableNames True env used av -findBindableNames arg env used (Elaboratable_As_Pattern fc _ _ nm@(UN (Basic n)) pat) +findBindableNames arg env used (Elaborable_As_Pattern fc _ _ nm@(UN (Basic n)) pat) = (nm, UN $ Basic $ genUniqueStr used n) :: findBindableNames arg env used pat -findBindableNames arg env used (Elaboratable_As_Pattern fc _ _ n pat) +findBindableNames arg env used (Elaborable_As_Pattern fc _ _ n pat) = findBindableNames arg env used pat -findBindableNames arg env used (Elaboratable_Must_Unify fc r pat) +findBindableNames arg env used (Elaborable_Must_Unify fc r pat) = findBindableNames arg env used pat -findBindableNames arg env used (Elaboratable_Delayed_Type fc r t) +findBindableNames arg env used (Elaborable_Delayed_Type fc r t) = findBindableNames arg env used t -findBindableNames arg env used (Elaboratable_Delay fc t) +findBindableNames arg env used (Elaborable_Delay fc t) = findBindableNames arg env used t -findBindableNames arg env used (Elaboratable_Force fc t) +findBindableNames arg env used (Elaborable_Force fc t) = findBindableNames arg env used t -findBindableNames arg env used (Elaboratable_Quote fc t) +findBindableNames arg env used (Elaborable_Quote fc t) = findBindableNamesQuot env used t -findBindableNames arg env used (Elaboratable_Quote_Declarations fc d) +findBindableNames arg env used (Elaborable_Quote_Declarations fc d) = findBindableNamesQuot env used !(rawImpFromDecl !d) -findBindableNames arg env used (Elaboratable_Alternative fc u alts) +findBindableNames arg env used (Elaborable_Alternative fc u alts) = concatMap (findBindableNames arg env used) alts -findBindableNames arg env used (Elaboratable_Record_Update fc updates tm) +findBindableNames arg env used (Elaborable_Record_Update fc updates tm) = findBindableNames True env used tm ++ concatMap (findBindableNames True env used . getFieldUpdateTerm) updates -- We've skipped case, let and local - rather than guess where the -- name should be bound, leave it to the programmer findBindableNames arg env used tm = [] -findBindableNamesQuot env used (Elaboratable_Dependent_Function_Type fc x y z argTy retTy) +findBindableNamesQuot env used (Elaborable_Dependent_Function_Type fc x y z argTy retTy) = findBindableNamesQuot env used ![argTy, retTy] -findBindableNamesQuot env used (Elaboratable_Lambda fc x y z argTy lamTy) +findBindableNamesQuot env used (Elaborable_Lambda fc x y z argTy lamTy) = findBindableNamesQuot env used ![argTy, lamTy] -findBindableNamesQuot env used (Elaboratable_Binding fc lhsfc x y nTy nVal scope) +findBindableNamesQuot env used (Elaborable_Binding fc lhsfc x y nTy nVal scope) = findBindableNamesQuot env used ![nTy, nVal, scope] -findBindableNamesQuot env used (Elaboratable_Case fc _ x ty xs) +findBindableNamesQuot env used (Elaborable_Case fc _ x ty xs) = findBindableNamesQuot env used !([x, ty] ++ getRawImp !xs) where getRawImp : ImpClause -> List RawImp getRawImp (PatClause fc1 lhs rhs) = [lhs, rhs] getRawImp (WithClause fc1 lhs rig wval prf flags ys) = [wval, lhs] ++ getRawImp !ys getRawImp (ImpossibleClause fc1 lhs) = [lhs] -findBindableNamesQuot env used (Elaboratable_Local_Definitions fc xs x) +findBindableNamesQuot env used (Elaborable_Local_Definitions fc xs x) = findBindableNamesQuot env used !(x :: rawImpFromDecl !xs) -findBindableNamesQuot env used (Elaboratable_Case_Local_Definition fc uname internalName args x) +findBindableNamesQuot env used (Elaborable_Case_Local_Definition fc uname internalName args x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (Elaboratable_Apply fc x y) +findBindableNamesQuot env used (Elaborable_Apply fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (Elaboratable_Named_Apply fc x y z) +findBindableNamesQuot env used (Elaborable_Named_Apply fc x y z) = findBindableNamesQuot env used ![x, z] -findBindableNamesQuot env used (Elaboratable_Automatic_Apply fc x y) +findBindableNamesQuot env used (Elaborable_Automatic_Apply fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (Elaboratable_With_Apply fc x y) +findBindableNamesQuot env used (Elaborable_With_Apply fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (Elaboratable_Rewrite fc x y) +findBindableNamesQuot env used (Elaborable_Rewrite fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (Elaboratable_Coerced fc x) +findBindableNamesQuot env used (Elaborable_Coerced fc x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (Elaboratable_Bind_Here fc x y) +findBindableNamesQuot env used (Elaborable_Bind_Here fc x y) = findBindableNamesQuot env used y -findBindableNamesQuot env used (Elaboratable_Record_Update fc xs x) +findBindableNamesQuot env used (Elaborable_Record_Update fc xs x) = findBindableNamesQuot env used !(x :: map getFieldUpdateTerm xs) -findBindableNamesQuot env used (Elaboratable_As_Pattern fc nfc x y z) +findBindableNamesQuot env used (Elaborable_As_Pattern fc nfc x y z) = findBindableNamesQuot env used z -findBindableNamesQuot env used (Elaboratable_Delayed_Type fc x y) +findBindableNamesQuot env used (Elaborable_Delayed_Type fc x y) = findBindableNamesQuot env used y -findBindableNamesQuot env used (Elaboratable_Delay fc x) +findBindableNamesQuot env used (Elaborable_Delay fc x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (Elaboratable_Force fc x) +findBindableNamesQuot env used (Elaborable_Force fc x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (Elaboratable_Unquote fc x) +findBindableNamesQuot env used (Elaborable_Unquote fc x) = findBindableNames True env used x -findBindableNamesQuot env used (Elaboratable_With_Unambiguous_Names fc xs x) +findBindableNamesQuot env used (Elaborable_With_Unambiguous_Names fc xs x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (Elaboratable_Name fc x) = [] -findBindableNamesQuot env used (Elaboratable_Search fc depth) = [] -findBindableNamesQuot env used (Elaboratable_Alternative fc x xs) = [] -findBindableNamesQuot env used (Elaboratable_Bind_Name fc x) = [] -findBindableNamesQuot env used (Elaboratable_Primitive_Value fc c) = [] -findBindableNamesQuot env used (Elaboratable_Type_Universe fc) = [] -findBindableNamesQuot env used (Elaboratable_Hole fc x) = [] +findBindableNamesQuot env used (Elaborable_Name fc x) = [] +findBindableNamesQuot env used (Elaborable_Search fc depth) = [] +findBindableNamesQuot env used (Elaborable_Alternative fc x xs) = [] +findBindableNamesQuot env used (Elaborable_Bind_Name fc x) = [] +findBindableNamesQuot env used (Elaborable_Primitive_Value fc c) = [] +findBindableNamesQuot env used (Elaborable_Type_Universe fc) = [] +findBindableNamesQuot env used (Elaborable_Hole fc x) = [] findBindableNamesQuot env used (Implicit fc bindIfUnsolved) = [] -- These are the ones I'm not sure about -findBindableNamesQuot env used (Elaboratable_Must_Unify fc x y) +findBindableNamesQuot env used (Elaborable_Must_Unify fc x y) = findBindableNamesQuot env used y -findBindableNamesQuot env used (Elaboratable_Unification_Log fc k x) +findBindableNamesQuot env used (Elaborable_Unification_Log fc k x) = findBindableNamesQuot env used x -- Should f `(g `(List ~(x))) bind "x" as a parameter to "f"? -- Depends how (or if) recursive quoting works -findBindableNamesQuot env used (Elaboratable_Quote fc x) = [] -findBindableNamesQuot env used (Elaboratable_Quote_Name fc x) = [] -findBindableNamesQuot env used (Elaboratable_Quote_Declarations fc xs) = [] -findBindableNamesQuot env used (Elaboratable_Run_Elaborator fc _ x) = [] +findBindableNamesQuot env used (Elaborable_Quote fc x) = [] +findBindableNamesQuot env used (Elaborable_Quote_Name fc x) = [] +findBindableNamesQuot env used (Elaborable_Quote_Declarations fc xs) = [] +findBindableNamesQuot env used (Elaborable_Run_Elaborator fc _ x) = [] ||| Lower-case names normally become implicit binders. A lower-case type or ||| data constructor introduced by Idric choice syntax is a global name @@ -233,43 +233,43 @@ findUniqueBindableNames fc arg env used t export findAllNames : (env : List Name) -> RawImp -> List Name -findAllNames env (Elaboratable_Name fc n) +findAllNames env (Elaborable_Name fc n) = if not (n `elem` env) then [n] else [] -findAllNames env (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) +findAllNames env (Elaborable_Dependent_Function_Type fc rig p mn aty retty) = let env' = case mn of Nothing => env Just n => n :: env in findAllNames env aty ++ findAllNames env' retty -findAllNames env (Elaboratable_Lambda fc rig p mn aty sc) +findAllNames env (Elaborable_Lambda fc rig p mn aty sc) = let env' = case mn of Nothing => env Just n => n :: env in findAllNames env' aty ++ findAllNames env' sc -findAllNames env (Elaboratable_Apply fc fn av) +findAllNames env (Elaborable_Apply fc fn av) = findAllNames env fn ++ findAllNames env av -findAllNames env (Elaboratable_Named_Apply fc fn n av) +findAllNames env (Elaborable_Named_Apply fc fn n av) = findAllNames env fn ++ findAllNames env av -findAllNames env (Elaboratable_Automatic_Apply fc fn av) +findAllNames env (Elaborable_Automatic_Apply fc fn av) = findAllNames env fn ++ findAllNames env av -findAllNames env (Elaboratable_With_Apply fc fn av) +findAllNames env (Elaborable_With_Apply fc fn av) = findAllNames env fn ++ findAllNames env av -findAllNames env (Elaboratable_As_Pattern fc _ _ n pat) +findAllNames env (Elaborable_As_Pattern fc _ _ n pat) = n :: findAllNames env pat -findAllNames env (Elaboratable_Must_Unify fc r pat) +findAllNames env (Elaborable_Must_Unify fc r pat) = findAllNames env pat -findAllNames env (Elaboratable_Delayed_Type fc r t) +findAllNames env (Elaborable_Delayed_Type fc r t) = findAllNames env t -findAllNames env (Elaboratable_Delay fc t) +findAllNames env (Elaborable_Delay fc t) = findAllNames env t -findAllNames env (Elaboratable_Force fc t) +findAllNames env (Elaborable_Force fc t) = findAllNames env t -findAllNames env (Elaboratable_Quote fc t) +findAllNames env (Elaborable_Quote fc t) = findAllNames env t -findAllNames env (Elaboratable_Unquote fc t) +findAllNames env (Elaborable_Unquote fc t) = findAllNames env t -findAllNames env (Elaboratable_Alternative fc u alts) +findAllNames env (Elaborable_Alternative fc u alts) = concatMap (findAllNames env) alts -findAllNames env (Elaboratable_Record_Update fc updates tm) +findAllNames env (Elaborable_Record_Update fc updates tm) = findAllNames env tm ++ concatMap (findAllNames env . getFieldUpdateTerm) updates ++ concatMap (map (UN . Basic) . getFieldUpdatePath) updates @@ -281,29 +281,29 @@ findAllNames env tm = [] -- the ones that mean the declaration will be added). export findIBindVars : RawImp -> List Name -findIBindVars (Elaboratable_Dependent_Function_Type fc rig p mn aty retty) +findIBindVars (Elaborable_Dependent_Function_Type fc rig p mn aty retty) = findIBindVars aty ++ findIBindVars retty -findIBindVars (Elaboratable_Lambda fc rig p mn aty sc) +findIBindVars (Elaborable_Lambda fc rig p mn aty sc) = findIBindVars aty ++ findIBindVars sc -findIBindVars (Elaboratable_Apply fc fn av) +findIBindVars (Elaborable_Apply fc fn av) = findIBindVars fn ++ findIBindVars av -findIBindVars (Elaboratable_Named_Apply fc fn n av) +findIBindVars (Elaborable_Named_Apply fc fn n av) = findIBindVars fn ++ findIBindVars av -findIBindVars (Elaboratable_Automatic_Apply fc fn av) +findIBindVars (Elaborable_Automatic_Apply fc fn av) = findIBindVars fn ++ findIBindVars av -findIBindVars (Elaboratable_With_Apply fc fn av) +findIBindVars (Elaborable_With_Apply fc fn av) = findIBindVars fn ++ findIBindVars av -findIBindVars (Elaboratable_Bind_Name fc v) +findIBindVars (Elaborable_Bind_Name fc v) = [v] -findIBindVars (Elaboratable_Delayed_Type fc r t) +findIBindVars (Elaborable_Delayed_Type fc r t) = findIBindVars t -findIBindVars (Elaboratable_Delay fc t) +findIBindVars (Elaborable_Delay fc t) = findIBindVars t -findIBindVars (Elaboratable_Force fc t) +findIBindVars (Elaborable_Force fc t) = findIBindVars t -findIBindVars (Elaboratable_Alternative fc u alts) +findIBindVars (Elaborable_Alternative fc u alts) = concatMap findIBindVars alts -findIBindVars (Elaboratable_Record_Update fc updates tm) +findIBindVars (Elaborable_Record_Update fc updates tm) = findIBindVars tm ++ concatMap (findIBindVars . getFieldUpdateTerm) updates -- We've skipped case, let and local - rather than guess where the -- name should be bound, leave it to the programmer @@ -314,63 +314,63 @@ mutual -- TODO association list should be map (should the `List Name` be a set as well?) substNames' : Bool -> List Name -> List (Name, RawImp) -> RawImp -> RawImp - substNames' False bound ps (Elaboratable_Name fc n) + substNames' False bound ps (Elaborable_Name fc n) = if not (n `elem` bound) then case lookup n ps of Just t => t - _ => Elaboratable_Name fc n - else Elaboratable_Name fc n - substNames' True bound ps (Elaboratable_Bind_Name fc n) + _ => Elaborable_Name fc n + else Elaborable_Name fc n + substNames' True bound ps (Elaborable_Bind_Name fc n) = if not (n `elem` bound) then case lookup n ps of Just t => t - _ => Elaboratable_Bind_Name fc n - else Elaboratable_Bind_Name fc n - substNames' bvar bound ps (Elaboratable_Dependent_Function_Type fc r p mn argTy retTy) + _ => Elaborable_Bind_Name fc n + else Elaborable_Bind_Name fc n + substNames' bvar bound ps (Elaborable_Dependent_Function_Type fc r p mn argTy retTy) = let bound' = maybe bound (\n => n :: bound) mn in - Elaboratable_Dependent_Function_Type fc r p mn (substNames' bvar bound ps argTy) + Elaborable_Dependent_Function_Type fc r p mn (substNames' bvar bound ps argTy) (substNames' bvar bound' ps retTy) - substNames' bvar bound ps (Elaboratable_Lambda fc r p mn argTy scope) + substNames' bvar bound ps (Elaborable_Lambda fc r p mn argTy scope) = let bound' = maybe bound (\n => n :: bound) mn in - Elaboratable_Lambda fc r p mn (substNames' bvar bound ps argTy) + Elaborable_Lambda fc r p mn (substNames' bvar bound ps argTy) (substNames' bvar bound' ps scope) - substNames' bvar bound ps (Elaboratable_Binding fc lhsFC r n nTy nVal scope) + substNames' bvar bound ps (Elaborable_Binding fc lhsFC r n nTy nVal scope) = let bound' = n :: bound in - Elaboratable_Binding fc lhsFC r n (substNames' bvar bound ps nTy) + Elaborable_Binding fc lhsFC r n (substNames' bvar bound ps nTy) (substNames' bvar bound ps nVal) (substNames' bvar bound' ps scope) - substNames' bvar bound ps (Elaboratable_Case fc opts y ty xs) - = Elaboratable_Case fc opts + substNames' bvar bound ps (Elaborable_Case fc opts y ty xs) + = Elaborable_Case fc opts (substNames' bvar bound ps y) (substNames' bvar bound ps ty) (map (substNamesClause' bvar bound ps) xs) - substNames' bvar bound ps (Elaboratable_Local_Definitions fc xs y) + substNames' bvar bound ps (Elaborable_Local_Definitions fc xs y) = let bound' = definedInBlock emptyNS xs ++ bound in - Elaboratable_Local_Definitions fc (map (substNamesDecl' bvar bound ps) xs) + Elaborable_Local_Definitions fc (map (substNamesDecl' bvar bound ps) xs) (substNames' bvar bound' ps y) - substNames' bvar bound ps (Elaboratable_Apply fc fn arg) - = Elaboratable_Apply fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) - substNames' bvar bound ps (Elaboratable_Named_Apply fc fn y arg) - = Elaboratable_Named_Apply fc (substNames' bvar bound ps fn) y (substNames' bvar bound ps arg) - substNames' bvar bound ps (Elaboratable_Automatic_Apply fc fn arg) - = Elaboratable_Automatic_Apply fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) - substNames' bvar bound ps (Elaboratable_With_Apply fc fn arg) - = Elaboratable_With_Apply fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) - substNames' bvar bound ps (Elaboratable_Alternative fc y xs) - = Elaboratable_Alternative fc y (map (substNames' bvar bound ps) xs) - substNames' bvar bound ps (Elaboratable_Coerced fc y) - = Elaboratable_Coerced fc (substNames' bvar bound ps y) - substNames' bvar bound ps (Elaboratable_As_Pattern fc nameFC s y pattern) - = Elaboratable_As_Pattern fc nameFC s y (substNames' bvar bound ps pattern) - substNames' bvar bound ps (Elaboratable_Must_Unify fc r pattern) - = Elaboratable_Must_Unify fc r (substNames' bvar bound ps pattern) - substNames' bvar bound ps (Elaboratable_Delayed_Type fc r t) - = Elaboratable_Delayed_Type fc r (substNames' bvar bound ps t) - substNames' bvar bound ps (Elaboratable_Delay fc t) - = Elaboratable_Delay fc (substNames' bvar bound ps t) - substNames' bvar bound ps (Elaboratable_Force fc t) - = Elaboratable_Force fc (substNames' bvar bound ps t) - substNames' bvar bound ps (Elaboratable_Record_Update fc updates tm) - = Elaboratable_Record_Update fc (map (mapFieldUpdateTerm $ substNames' bvar bound ps) updates) + substNames' bvar bound ps (Elaborable_Apply fc fn arg) + = Elaborable_Apply fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) + substNames' bvar bound ps (Elaborable_Named_Apply fc fn y arg) + = Elaborable_Named_Apply fc (substNames' bvar bound ps fn) y (substNames' bvar bound ps arg) + substNames' bvar bound ps (Elaborable_Automatic_Apply fc fn arg) + = Elaborable_Automatic_Apply fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) + substNames' bvar bound ps (Elaborable_With_Apply fc fn arg) + = Elaborable_With_Apply fc (substNames' bvar bound ps fn) (substNames' bvar bound ps arg) + substNames' bvar bound ps (Elaborable_Alternative fc y xs) + = Elaborable_Alternative fc y (map (substNames' bvar bound ps) xs) + substNames' bvar bound ps (Elaborable_Coerced fc y) + = Elaborable_Coerced fc (substNames' bvar bound ps y) + substNames' bvar bound ps (Elaborable_As_Pattern fc nameFC s y pattern) + = Elaborable_As_Pattern fc nameFC s y (substNames' bvar bound ps pattern) + substNames' bvar bound ps (Elaborable_Must_Unify fc r pattern) + = Elaborable_Must_Unify fc r (substNames' bvar bound ps pattern) + substNames' bvar bound ps (Elaborable_Delayed_Type fc r t) + = Elaborable_Delayed_Type fc r (substNames' bvar bound ps t) + substNames' bvar bound ps (Elaborable_Delay fc t) + = Elaborable_Delay fc (substNames' bvar bound ps t) + substNames' bvar bound ps (Elaborable_Force fc t) + = Elaborable_Force fc (substNames' bvar bound ps t) + substNames' bvar bound ps (Elaborable_Record_Update fc updates tm) + = Elaborable_Record_Update fc (map (mapFieldUpdateTerm $ substNames' bvar bound ps) updates) (substNames' bvar bound ps tm) substNames' bvar bound ps tm = tm @@ -401,16 +401,16 @@ mutual substNamesDecl' : Bool -> List Name -> List (Name, RawImp ) -> ImpDecl -> ImpDecl - substNamesDecl' bvar bound ps (Elaboratable_Claim claim) - = Elaboratable_Claim $ map {type $= map (substNames' bvar bound ps)} claim - substNamesDecl' bvar bound ps (Elaboratable_Definition fc n cs) - = Elaboratable_Definition fc n (map (substNamesClause' bvar bound ps) cs) - substNamesDecl' bvar bound ps (Elaboratable_Data_Declaration fc vis mbtot d) - = Elaboratable_Data_Declaration fc vis mbtot (substNamesData' bvar bound ps d) - substNamesDecl' bvar bound ps (Elaboratable_Expected_Failure fc msg ds) - = Elaboratable_Expected_Failure fc msg (map (substNamesDecl' bvar bound ps) ds) - substNamesDecl' bvar bound ps (Elaboratable_Namespace_Block fc ns ds) - = Elaboratable_Namespace_Block fc ns (map (substNamesDecl' bvar bound ps) ds) + substNamesDecl' bvar bound ps (Elaborable_Claim claim) + = Elaborable_Claim $ map {type $= map (substNames' bvar bound ps)} claim + substNamesDecl' bvar bound ps (Elaborable_Definition fc n cs) + = Elaborable_Definition fc n (map (substNamesClause' bvar bound ps) cs) + substNamesDecl' bvar bound ps (Elaborable_Data_Declaration fc vis mbtot d) + = Elaborable_Data_Declaration fc vis mbtot (substNamesData' bvar bound ps d) + substNamesDecl' bvar bound ps (Elaborable_Expected_Failure fc msg ds) + = Elaborable_Expected_Failure fc msg (map (substNamesDecl' bvar bound ps) ds) + substNamesDecl' bvar bound ps (Elaborable_Namespace_Block fc ns ds) + = Elaborable_Namespace_Block fc ns (map (substNamesDecl' bvar bound ps) ds) substNamesDecl' bvar bound ps d = d export @@ -431,47 +431,47 @@ substNamesClause = substNamesClause' False mutual export substLoc : FC -> RawImp -> RawImp - substLoc fc' (Elaboratable_Name fc n) = Elaboratable_Name fc' n - substLoc fc' (Elaboratable_Dependent_Function_Type fc r p mn argTy retTy) - = Elaboratable_Dependent_Function_Type fc' r p mn (substLoc fc' argTy) + substLoc fc' (Elaborable_Name fc n) = Elaborable_Name fc' n + substLoc fc' (Elaborable_Dependent_Function_Type fc r p mn argTy retTy) + = Elaborable_Dependent_Function_Type fc' r p mn (substLoc fc' argTy) (substLoc fc' retTy) - substLoc fc' (Elaboratable_Lambda fc r p mn argTy scope) - = Elaboratable_Lambda fc' r p mn (substLoc fc' argTy) + substLoc fc' (Elaborable_Lambda fc r p mn argTy scope) + = Elaborable_Lambda fc' r p mn (substLoc fc' argTy) (substLoc fc' scope) - substLoc fc' (Elaboratable_Binding fc lhsFC r n nTy nVal scope) - = Elaboratable_Binding fc' fc' r n (substLoc fc' nTy) + substLoc fc' (Elaborable_Binding fc lhsFC r n nTy nVal scope) + = Elaborable_Binding fc' fc' r n (substLoc fc' nTy) (substLoc fc' nVal) (substLoc fc' scope) - substLoc fc' (Elaboratable_Case fc opts y ty xs) - = Elaboratable_Case fc' opts (substLoc fc' y) (substLoc fc' ty) + substLoc fc' (Elaborable_Case fc opts y ty xs) + = Elaborable_Case fc' opts (substLoc fc' y) (substLoc fc' ty) (map (substLocClause fc') xs) - substLoc fc' (Elaboratable_Local_Definitions fc xs y) - = Elaboratable_Local_Definitions fc' (map (substLocDecl fc') xs) + substLoc fc' (Elaborable_Local_Definitions fc xs y) + = Elaborable_Local_Definitions fc' (map (substLocDecl fc') xs) (substLoc fc' y) - substLoc fc' (Elaboratable_Apply fc fn arg) - = Elaboratable_Apply fc' (substLoc fc' fn) (substLoc fc' arg) - substLoc fc' (Elaboratable_Named_Apply fc fn y arg) - = Elaboratable_Named_Apply fc' (substLoc fc' fn) y (substLoc fc' arg) - substLoc fc' (Elaboratable_Automatic_Apply fc fn arg) - = Elaboratable_Automatic_Apply fc' (substLoc fc' fn) (substLoc fc' arg) - substLoc fc' (Elaboratable_With_Apply fc fn arg) - = Elaboratable_With_Apply fc' (substLoc fc' fn) (substLoc fc' arg) - substLoc fc' (Elaboratable_Alternative fc y xs) - = Elaboratable_Alternative fc' y (map (substLoc fc') xs) - substLoc fc' (Elaboratable_Coerced fc y) - = Elaboratable_Coerced fc' (substLoc fc' y) - substLoc fc' (Elaboratable_As_Pattern fc nameFC s y pattern) - = Elaboratable_As_Pattern fc' fc' s y (substLoc fc' pattern) - substLoc fc' (Elaboratable_Must_Unify fc r pattern) - = Elaboratable_Must_Unify fc' r (substLoc fc' pattern) - substLoc fc' (Elaboratable_Delayed_Type fc r t) - = Elaboratable_Delayed_Type fc' r (substLoc fc' t) - substLoc fc' (Elaboratable_Delay fc t) - = Elaboratable_Delay fc' (substLoc fc' t) - substLoc fc' (Elaboratable_Force fc t) - = Elaboratable_Force fc' (substLoc fc' t) - substLoc fc' (Elaboratable_Record_Update fc updates tm) - = Elaboratable_Record_Update fc' (map (mapFieldUpdateTerm $ substLoc fc') updates) + substLoc fc' (Elaborable_Apply fc fn arg) + = Elaborable_Apply fc' (substLoc fc' fn) (substLoc fc' arg) + substLoc fc' (Elaborable_Named_Apply fc fn y arg) + = Elaborable_Named_Apply fc' (substLoc fc' fn) y (substLoc fc' arg) + substLoc fc' (Elaborable_Automatic_Apply fc fn arg) + = Elaborable_Automatic_Apply fc' (substLoc fc' fn) (substLoc fc' arg) + substLoc fc' (Elaborable_With_Apply fc fn arg) + = Elaborable_With_Apply fc' (substLoc fc' fn) (substLoc fc' arg) + substLoc fc' (Elaborable_Alternative fc y xs) + = Elaborable_Alternative fc' y (map (substLoc fc') xs) + substLoc fc' (Elaborable_Coerced fc y) + = Elaborable_Coerced fc' (substLoc fc' y) + substLoc fc' (Elaborable_As_Pattern fc nameFC s y pattern) + = Elaborable_As_Pattern fc' fc' s y (substLoc fc' pattern) + substLoc fc' (Elaborable_Must_Unify fc r pattern) + = Elaborable_Must_Unify fc' r (substLoc fc' pattern) + substLoc fc' (Elaborable_Delayed_Type fc r t) + = Elaborable_Delayed_Type fc' r (substLoc fc' t) + substLoc fc' (Elaborable_Delay fc t) + = Elaborable_Delay fc' (substLoc fc' t) + substLoc fc' (Elaborable_Force fc t) + = Elaborable_Force fc' (substLoc fc' t) + substLoc fc' (Elaborable_Record_Update fc updates tm) + = Elaborable_Record_Update fc' (map (mapFieldUpdateTerm $ substLoc fc') updates) (substLoc fc' tm) substLoc fc' tm = tm @@ -497,16 +497,16 @@ mutual = MkImpLater fc' n (substLoc fc' con) substLocDecl : FC -> ImpDecl -> ImpDecl - substLocDecl fc' (Elaboratable_Claim (MkWithData _ $ Make_Elaboratable_Claim_Data r vis opts td)) - = Elaboratable_Claim (MkFCVal fc' $ Make_Elaboratable_Claim_Data r vis opts (map (substLoc fc') (set "fc" fc' td))) - substLocDecl fc' (Elaboratable_Definition fc n cs) - = Elaboratable_Definition fc' n (map (substLocClause fc') cs) - substLocDecl fc' (Elaboratable_Data_Declaration fc vis mbtot d) - = Elaboratable_Data_Declaration fc' vis mbtot (substLocData fc' d) - substLocDecl fc' (Elaboratable_Expected_Failure fc msg ds) - = Elaboratable_Expected_Failure fc' msg (map (substLocDecl fc') ds) - substLocDecl fc' (Elaboratable_Namespace_Block fc ns ds) - = Elaboratable_Namespace_Block fc' ns (map (substLocDecl fc') ds) + substLocDecl fc' (Elaborable_Claim (MkWithData _ $ Make_Elaborable_Claim_Data r vis opts td)) + = Elaborable_Claim (MkFCVal fc' $ Make_Elaborable_Claim_Data r vis opts (map (substLoc fc') (set "fc" fc' td))) + substLocDecl fc' (Elaborable_Definition fc n cs) + = Elaborable_Definition fc' n (map (substLocClause fc') cs) + substLocDecl fc' (Elaborable_Data_Declaration fc vis mbtot d) + = Elaborable_Data_Declaration fc' vis mbtot (substLocData fc' d) + substLocDecl fc' (Elaborable_Expected_Failure fc msg ds) + = Elaborable_Expected_Failure fc' msg (map (substLocDecl fc') ds) + substLocDecl fc' (Elaborable_Namespace_Block fc ns ds) + = Elaborable_Namespace_Block fc' ns (map (substLocDecl fc') ds) substLocDecl fc' d = d nameNum : String -> (String, Maybe Int) @@ -681,13 +681,13 @@ etaExpandImplicits fc ty lhs rhs pure (apply lhs lhsArgs, apply rhs rhsArgs) where collectImplicits : RawImp -> List Name - collectImplicits (Elaboratable_Dependent_Function_Type _ _ Explicit _ _ ty) = [] - collectImplicits (Elaboratable_Dependent_Function_Type _ _ _ (Just n) _ ty) = n :: collectImplicits ty + collectImplicits (Elaborable_Dependent_Function_Type _ _ Explicit _ _ ty) = [] + collectImplicits (Elaborable_Dependent_Function_Type _ _ _ (Just n) _ ty) = n :: collectImplicits ty collectImplicits _ = [] ivar : (bind : Bool) -> Name -> RawImp - ivar True = Elaboratable_Bind_Name fc - ivar False = Elaboratable_Name fc + ivar True = Elaborable_Bind_Name fc + ivar False = Elaborable_Name fc makeArg : (bind : Bool) -> (Name, Name) -> Arg makeArg bind (n, bindName) = Named fc n $ ivar bind bindName diff --git a/TTImp/WithClause.idr b/TTImp/WithClause.idr index 67e8d72615..8e2c97657a 100644 --- a/TTImp/WithClause.idr +++ b/TTImp/WithClause.idr @@ -15,11 +15,11 @@ matchFail loc = throw (GenericMsg loc "With clause does not match parent") --- To be used on the lhs of a nested with clause to figure out a tight location --- information to give to the generated LHS getHeadLoc : RawImp -> Core FC -getHeadLoc (Elaboratable_Name fc _) = pure fc -getHeadLoc (Elaboratable_Apply _ f _) = getHeadLoc f -getHeadLoc (Elaboratable_With_Apply _ f _) = getHeadLoc f -getHeadLoc (Elaboratable_Automatic_Apply _ f _) = getHeadLoc f -getHeadLoc (Elaboratable_Named_Apply _ f _ _) = getHeadLoc f +getHeadLoc (Elaborable_Name fc _) = pure fc +getHeadLoc (Elaborable_Apply _ f _) = getHeadLoc f +getHeadLoc (Elaborable_With_Apply _ f _) = getHeadLoc f +getHeadLoc (Elaborable_Automatic_Apply _ f _) = getHeadLoc f +getHeadLoc (Elaborable_Named_Apply _ f _ _) = getHeadLoc f getHeadLoc t = throw (InternalError $ "Could not find head of LHS: " ++ show t) addAlias : {auto m : Ref MD Metadata} -> @@ -38,71 +38,71 @@ mutual {auto c : Ref Ctxt Defs} -> (lhs : Bool) -> RawImp -> RawImp -> Core (List (Name, RawImp)) - getMatch lhs (Elaboratable_Bind_Name to n) tm@(Elaboratable_Bind_Name from _) + getMatch lhs (Elaborable_Bind_Name to n) tm@(Elaborable_Bind_Name from _) = [(n, tm)] <$ addAlias from to - getMatch lhs (Elaboratable_Bind_Name _ n) tm = pure [(n, tm)] + getMatch lhs (Elaborable_Bind_Name _ n) tm = pure [(n, tm)] getMatch lhs (Implicit {}) tm = pure [] - getMatch lhs _ (Elaboratable_Must_Unify _ UserDotted _) = pure [] + getMatch lhs _ (Elaborable_Must_Unify _ UserDotted _) = pure [] - getMatch lhs (Elaboratable_Name to (NS ns n)) (Elaboratable_Name from (NS ns' n')) + getMatch lhs (Elaborable_Name to (NS ns n)) (Elaborable_Name from (NS ns' n')) = if n == n' && isParentOf ns' ns then [] <$ addAlias from to -- <$ decorateName loc nm else matchFail from - getMatch lhs (Elaboratable_Name to (NS ns n)) (Elaboratable_Name from n') + getMatch lhs (Elaborable_Name to (NS ns n)) (Elaborable_Name from n') = if n == n' then [] <$ addAlias from to -- <$ decorateName loc (NS ns n') else matchFail from - getMatch lhs (Elaboratable_Name to n) (Elaboratable_Name from n') + getMatch lhs (Elaborable_Name to n) (Elaborable_Name from n') = if n == n' then [] <$ addAlias from to -- <$ decorateName loc n' else matchFail from - getMatch lhs (Elaboratable_Dependent_Function_Type _ c p n arg ret) (Elaboratable_Dependent_Function_Type loc c' p' n' arg' ret') + getMatch lhs (Elaborable_Dependent_Function_Type _ c p n arg ret) (Elaborable_Dependent_Function_Type loc c' p' n' arg' ret') = if c == c' && eqPiInfoBy (\_, _ => True) p p' && n == n' then matchAll lhs [(arg, arg'), (ret, ret')] else matchFail loc -- TODO: Lam, Let, Case, Local, Update - getMatch lhs (Elaboratable_Apply _ f a) (Elaboratable_Apply loc f' a') + getMatch lhs (Elaborable_Apply _ f a) (Elaborable_Apply loc f' a') = matchAll lhs [(f, f'), (a, a')] - getMatch lhs (Elaboratable_Automatic_Apply _ f a) (Elaboratable_Automatic_Apply loc f' a') + getMatch lhs (Elaborable_Automatic_Apply _ f a) (Elaborable_Automatic_Apply loc f' a') = matchAll lhs [(f, f'), (a, a')] - getMatch lhs (Elaboratable_Named_Apply _ f n a) (Elaboratable_Named_Apply loc f' n' a') + getMatch lhs (Elaborable_Named_Apply _ f n a) (Elaborable_Named_Apply loc f' n' a') = if n == n' then matchAll lhs [(f, f'), (a, a')] else matchFail loc - getMatch lhs (Elaboratable_With_Apply _ f a) (Elaboratable_With_Apply loc f' a') + getMatch lhs (Elaborable_With_Apply _ f a) (Elaborable_With_Apply loc f' a') = matchAll lhs [(f, f'), (a, a')] -- On LHS: If there's an implicit in the parent, but not the clause, add the -- implicit to the clause. This will propagate the implicit through to the -- body - getMatch True (Elaboratable_Named_Apply fc f n a) f' + getMatch True (Elaborable_Named_Apply fc f n a) f' = matchAll True [(f, f'), (a, a)] - getMatch True (Elaboratable_Automatic_Apply fc f a) f' + getMatch True (Elaborable_Automatic_Apply fc f a) f' = matchAll True [(f, f'), (a, a)] -- On RHS: Rely on unification to fill in the implicit - getMatch False (Elaboratable_Named_Apply fc f n a) f' + getMatch False (Elaborable_Named_Apply fc f n a) f' = getMatch False f f' - getMatch False (Elaboratable_Automatic_Apply fc f a) f' + getMatch False (Elaborable_Automatic_Apply fc f a) f' = getMatch False f f' -- Can't have an implicit in the clause if there wasn't a matching -- implicit in the parent - getMatch lhs f (Elaboratable_Named_Apply fc f' n a) + getMatch lhs f (Elaborable_Named_Apply fc f' n a) = matchFail fc - getMatch lhs f (Elaboratable_Automatic_Apply fc f' a) + getMatch lhs f (Elaborable_Automatic_Apply fc f' a) = matchFail fc -- Alternatives are okay as long as the alternatives correspond, and -- one of them is okay - getMatch lhs (Elaboratable_Alternative _ _ as) (Elaboratable_Alternative fc _ as') + getMatch lhs (Elaborable_Alternative _ _ as) (Elaborable_Alternative fc _ as') = matchAny fc lhs (zip as as') - getMatch lhs (Elaboratable_As_Pattern _ _ _ nm@(UN (Basic _)) p) (Elaboratable_As_Pattern _ fc _ nm'@(UN (Basic _)) p') + getMatch lhs (Elaborable_As_Pattern _ _ _ nm@(UN (Basic _)) p) (Elaborable_As_Pattern _ fc _ nm'@(UN (Basic _)) p') = do ms <- getMatch lhs p p' - mergeMatches lhs ((nm, Elaboratable_As_Pattern fc emptyFC UseLeft nm' (Implicit fc True)) :: ms) - getMatch lhs (Elaboratable_As_Pattern _ _ _ nm@(UN (Basic _)) p) p' + mergeMatches lhs ((nm, Elaborable_As_Pattern fc emptyFC UseLeft nm' (Implicit fc True)) :: ms) + getMatch lhs (Elaborable_As_Pattern _ _ _ nm@(UN (Basic _)) p) p' = do ms <- getMatch lhs p p' mergeMatches lhs ((nm, p') :: ms) - getMatch lhs (Elaboratable_As_Pattern _ _ _ _ p) p' = getMatch lhs p p' - getMatch lhs p (Elaboratable_As_Pattern _ _ _ _ p') = getMatch lhs p p' - getMatch lhs (Elaboratable_Type_Universe _) (Elaboratable_Type_Universe _) = pure [] - getMatch lhs (Elaboratable_Primitive_Value fc c) (Elaboratable_Primitive_Value fc' c') = + getMatch lhs (Elaborable_As_Pattern _ _ _ _ p) p' = getMatch lhs p p' + getMatch lhs p (Elaborable_As_Pattern _ _ _ _ p') = getMatch lhs p p' + getMatch lhs (Elaborable_Type_Universe _) (Elaborable_Type_Universe _) = pure [] + getMatch lhs (Elaborable_Primitive_Value fc c) (Elaborable_Primitive_Value fc' c') = if c == c' then pure [] else matchFail fc' @@ -151,9 +151,9 @@ getArgMatch ploc mode True warg ms (Just (AutoImplicit, nm)) = case lookup nm ms of Just tm => tm Nothing => - let arg = Elaboratable_Search ploc 500 in + let arg = Elaborable_Search ploc 500 in if isJust (isLHS mode) - then Elaboratable_As_Pattern ploc ploc UseLeft nm arg + then Elaborable_As_Pattern ploc ploc UseLeft nm arg else arg getArgMatch ploc mode search warg ms (Just (_, nm)) = case lookup nm ms of @@ -161,7 +161,7 @@ getArgMatch ploc mode search warg ms (Just (_, nm)) Nothing => let arg = Implicit ploc True in if isJust (isLHS mode) - then Elaboratable_As_Pattern ploc ploc UseLeft nm arg + then Elaborable_As_Pattern ploc ploc UseLeft nm arg else arg export @@ -196,17 +196,17 @@ getNewLHS iploc drop nest wname wargnames lhs_raw patlhs log "declare.def.clause.with" 5 $ "Parameters: " ++ show params hdloc <- getHeadLoc patlhs - let newlhs = apply (Elaboratable_Name hdloc wname) (params ++ rest) + let newlhs = apply (Elaborable_Name hdloc wname) (params ++ rest) log "declare.def.clause.with" 5 $ "New LHS: " ++ show newlhs pure newlhs where dropWithArgs : Nat -> RawImp -> Core (RawImp, List RawImp) dropWithArgs Z tm = pure (tm, []) - dropWithArgs (S k) (Elaboratable_Apply _ f arg) + dropWithArgs (S k) (Elaborable_Apply _ f arg) = do (tm, rest) <- dropWithArgs k f pure (tm, arg :: rest) - dropWithArgs (S k) (Elaboratable_With_Apply _ f arg) + dropWithArgs (S k) (Elaborable_With_Apply _ f arg) = do (tm, rest) <- dropWithArgs k f pure (tm, arg :: rest) -- Shouldn't happen if parsed correctly, but there's no guarantee that @@ -225,10 +225,10 @@ withRHS fc drop wname wargnames tm toplhs where withApply : FC -> RawImp -> List RawImp -> RawImp withApply fc f [] = f - withApply fc f (a :: as) = withApply fc (Elaboratable_With_Apply fc f a) as + withApply fc f (a :: as) = withApply fc (Elaborable_With_Apply fc f a) as updateWith : FC -> RawImp -> List RawImp -> Core RawImp - updateWith fc (Elaboratable_With_Apply _ f a) ws = updateWith fc f (a :: ws) + updateWith fc (Elaborable_With_Apply _ f a) ws = updateWith fc f (a :: ws) updateWith fc tm [] = throw (GenericMsg fc "Badly formed 'with' application") updateWith fc tm (arg :: args) @@ -236,7 +236,7 @@ withRHS fc drop wname wargnames tm toplhs ms <- getMatch False toplhs tm hdloc <- getHeadLoc tm log "declare.def.clause.with" 10 $ "Result: " ++ show ms - let newrhs = apply (Elaboratable_Name hdloc wname) + let newrhs = apply (Elaborable_Name hdloc wname) (map (getArgMatch fc InExpr True arg ms) wargnames) log "declare.def.clause.with" 10 $ "With args for RHS: " ++ show wargnames log "declare.def.clause.with" 10 $ "New RHS: " ++ show newrhs @@ -244,29 +244,29 @@ withRHS fc drop wname wargnames tm toplhs mutual wrhs : RawImp -> Core RawImp - wrhs (Elaboratable_Dependent_Function_Type fc c p n ty sc) - = pure $ Elaboratable_Dependent_Function_Type fc c p n !(wrhs ty) !(wrhs sc) - wrhs (Elaboratable_Lambda fc c p n ty sc) - = pure $ Elaboratable_Lambda fc c p n !(wrhs ty) !(wrhs sc) - wrhs (Elaboratable_Binding fc lhsFC c n ty val sc) - = pure $ Elaboratable_Binding fc lhsFC c n !(wrhs ty) !(wrhs val) !(wrhs sc) - wrhs (Elaboratable_Case fc opts sc ty clauses) - = pure $ Elaboratable_Case fc opts !(wrhs sc) !(wrhs ty) !(traverse wrhsC clauses) - wrhs (Elaboratable_Local_Definitions fc decls sc) - = pure $ Elaboratable_Local_Definitions fc decls !(wrhs sc) -- TODO! - wrhs (Elaboratable_Record_Update fc upds tm) - = pure $ Elaboratable_Record_Update fc upds !(wrhs tm) -- TODO! - wrhs (Elaboratable_Apply fc f a) - = pure $ Elaboratable_Apply fc !(wrhs f) !(wrhs a) - wrhs (Elaboratable_Automatic_Apply fc f a) - = pure $ Elaboratable_Automatic_Apply fc !(wrhs f) !(wrhs a) - wrhs (Elaboratable_Named_Apply fc f n a) - = pure $ Elaboratable_Named_Apply fc !(wrhs f) n !(wrhs a) - wrhs (Elaboratable_With_Apply fc f a) = updateWith fc f [a] - wrhs (Elaboratable_Rewrite fc rule tm) = pure $ Elaboratable_Rewrite fc !(wrhs rule) !(wrhs tm) - wrhs (Elaboratable_Delayed_Type fc r tm) = pure $ Elaboratable_Delayed_Type fc r !(wrhs tm) - wrhs (Elaboratable_Delay fc tm) = pure $ Elaboratable_Delay fc !(wrhs tm) - wrhs (Elaboratable_Force fc tm) = pure $ Elaboratable_Force fc !(wrhs tm) + wrhs (Elaborable_Dependent_Function_Type fc c p n ty sc) + = pure $ Elaborable_Dependent_Function_Type fc c p n !(wrhs ty) !(wrhs sc) + wrhs (Elaborable_Lambda fc c p n ty sc) + = pure $ Elaborable_Lambda fc c p n !(wrhs ty) !(wrhs sc) + wrhs (Elaborable_Binding fc lhsFC c n ty val sc) + = pure $ Elaborable_Binding fc lhsFC c n !(wrhs ty) !(wrhs val) !(wrhs sc) + wrhs (Elaborable_Case fc opts sc ty clauses) + = pure $ Elaborable_Case fc opts !(wrhs sc) !(wrhs ty) !(traverse wrhsC clauses) + wrhs (Elaborable_Local_Definitions fc decls sc) + = pure $ Elaborable_Local_Definitions fc decls !(wrhs sc) -- TODO! + wrhs (Elaborable_Record_Update fc upds tm) + = pure $ Elaborable_Record_Update fc upds !(wrhs tm) -- TODO! + wrhs (Elaborable_Apply fc f a) + = pure $ Elaborable_Apply fc !(wrhs f) !(wrhs a) + wrhs (Elaborable_Automatic_Apply fc f a) + = pure $ Elaborable_Automatic_Apply fc !(wrhs f) !(wrhs a) + wrhs (Elaborable_Named_Apply fc f n a) + = pure $ Elaborable_Named_Apply fc !(wrhs f) n !(wrhs a) + wrhs (Elaborable_With_Apply fc f a) = updateWith fc f [a] + wrhs (Elaborable_Rewrite fc rule tm) = pure $ Elaborable_Rewrite fc !(wrhs rule) !(wrhs tm) + wrhs (Elaborable_Delayed_Type fc r tm) = pure $ Elaborable_Delayed_Type fc r !(wrhs tm) + wrhs (Elaborable_Delay fc tm) = pure $ Elaborable_Delay fc !(wrhs tm) + wrhs (Elaborable_Force fc tm) = pure $ Elaborable_Force fc !(wrhs tm) wrhs tm = pure tm wrhsC : ImpClause -> Core ImpClause diff --git a/Yaffle/REPL.idr b/Yaffle/REPL.idr index de8590edde..c72f6f2154 100644 --- a/Yaffle/REPL.idr +++ b/Yaffle/REPL.idr @@ -41,7 +41,7 @@ process (Eval ttimp) tmnf <- normalise defs Env.empty tm coreLift_ (printLn !(unelab Env.empty tmnf)) pure True -process (Check (Elaboratable_Name _ n)) +process (Check (Elaborable_Name _ n)) = do defs <- get Ctxt ns <- lookupTyName n (gamma defs) traverse_ printName ns diff --git a/_/docs/source/backends/backend-cookbook.rst b/_/docs/source/backends/backend-cookbook.rst index 4e77c59805..67f7a884b1 100644 --- a/_/docs/source/backends/backend-cookbook.rst +++ b/_/docs/source/backends/backend-cookbook.rst @@ -83,7 +83,7 @@ The ``CompileData`` contains: - A main expression that will be the entry point for the program in ``CExp`` - A list of ``Core.CompileExpr.NamedDef`` - A list of lambda-lifted definitions ``Compiler.LambdaLift.LiftedDef`` -- A list of ``Compiler.ANF.ANFDef`` +- A list of ``Compiler.ANF.Administrative_Normal_Form_Definition`` - A list of ``Compiler.VMCode.VMDef`` definitions These lists contain: @@ -126,7 +126,7 @@ definitions that needs to be compiled. These are: - ``NamedDef`` - ``LiftedDef`` -- ``ANFDef`` +- ``Administrative_Normal_Form_Definition`` - ``VMDef`` The question to answer here is: Which one should be picked? @@ -527,18 +527,18 @@ stores a ``Nat`` together with a proof that it points to a valid name in the local scope. ``ANF`` is a lower level representation where this kind of guarantees are not -present anymore. A local variable is represented using the ``AV`` constructor -which stores an ``AVar`` whose definition we include below. -The ``ALocal`` constructor stores an ``Int`` that corresponds to the ``Nat`` +present anymore. A local variable is represented using the ``Administrative_Normal_Form_Variable_Expression`` constructor +which stores an ``Administrative_Normal_Form_Variable`` whose definition we include below. +The ``Administrative_Normal_Form_Local_Variable`` constructor stores an ``Int`` that corresponds to the ``Nat`` we would have seen in ``Lifted``. -The ``ANull`` constructor refers to an erased variable and its representation +The ``Administrative_Normal_Form_Erased_Variable`` constructor refers to an erased variable and its representation in the host language will depend on the design choices made in the 'How to represent ``Erased`` values' section. .. .code-block:: idri - data AVar : Type where - ALocal : Int -> AVar - ANull : AVar + data Administrative_Normal_Form_Variable : Type where + Administrative_Normal_Form_Local_Variable : Int -> Administrative_Normal_Form_Variable + Administrative_Normal_Form_Erased_Variable : Administrative_Normal_Form_Variable VMDef specificities ~~~~~~~~~~~~~~~~~~~ From f7685609860656b126217b7f6dcae44ca09210a5 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:41:05 -0400 Subject: [PATCH 10/80] Register one-step codegen name --- Core/Options.idr | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Core/Options.idr b/Core/Options.idr index 366c33f21b..6a467b5d08 100644 --- a/Core/Options.idr +++ b/Core/Options.idr @@ -232,6 +232,7 @@ availableCGs o ("javascript", Javascript), ("refc", RefC), ("gambit", Gambit), + ("idric-one-step", Other "idric-one-step"), ("vmcode-interp", VMCodeInterp)] ++ additionalCGs o export @@ -282,7 +283,7 @@ defaultHashFn Nothing <- coreLift $ pathLookup ["sha256"] | Just p => pure $ Just p Nothing <- coreLift $ pathLookup ["openssl"] - | Just p => pure $ Just $ p ++ " sha256" + | Just p => pure $ Just p ++ " sha256" pure Nothing export From 7ec3222341a80f337a7ca451cd5fcc85a020c39c Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:41:57 -0400 Subject: [PATCH 11/80] Restore one-step codegen dispatch --- Idris/ProcessIdr.idr | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Idris/ProcessIdr.idr b/Idris/ProcessIdr.idr index 8b8596bc8b..c6ae6ec9b3 100644 --- a/Idris/ProcessIdr.idr +++ b/Idris/ProcessIdr.idr @@ -8,6 +8,7 @@ import Compiler.Scheme.Gambit import Compiler.ES.Node import Compiler.ES.Javascript import Compiler.Common +import Compiler.IdricOneStep import Compiler.Inline import Compiler.Interpreter.VMCode @@ -275,6 +276,7 @@ getCG Node = pure $ Just codegenNode getCG Javascript = pure $ Just codegenJavascript getCG RefC = pure $ Just codegenRefC getCG VMCodeInterp = pure $ Just codegenVMCodeInterp +getCG (Other "idric-one-step") = pure $ Just codegenIdricOneStep getCG (Other s) = getCodegen s export From 6951dfdc1053f7b90d704838266cda86b44ce397 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:42:05 -0400 Subject: [PATCH 12/80] Restore checked one-step codegen --- Compiler/IdricOneStep.idr | 50 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 Compiler/IdricOneStep.idr diff --git a/Compiler/IdricOneStep.idr b/Compiler/IdricOneStep.idr new file mode 100644 index 0000000000..80d6c7726f --- /dev/null +++ b/Compiler/IdricOneStep.idr @@ -0,0 +1,50 @@ +module Compiler.IdricOneStep + +import Compiler.ANF +import Compiler.Common +import Compiler.CompileExpr + +import Core.Name + +import Idris.Syntax + +import Libraries.Utils.Path + +%default covering + +renderName : Name -> String +renderName (DN _ name) = show name +renderName name = show name + +renderDefinition : (Name, Administrative_Normal_Form_Definition) -> String +renderDefinition (name, definition) = + renderName name ++ " = " ++ show definition ++ "\n" + +compileOneStep : + Ref Ctxt Defs -> + Ref Syn SyntaxInfo -> + (temporaryDirectory : String) -> + (outputDirectory : String) -> + ClosedTerm -> + (outputFile : String) -> + Core (Maybe String) +compileOneStep _ _ _ outputDirectory term outputFile = do + checked <- getCompileData False Administrative_Normal_Form term + let output = outputDirectory outputFile + let body = "EDRIC_ONE_STEP_BODY\t1\n" ++ + concat (map renderDefinition (anf checked)) + Core.writeFile output body + pure (Just output) + +executeOneStep : + Ref Ctxt Defs -> + Ref Syn SyntaxInfo -> + (temporaryDirectory : String) -> + ClosedTerm -> + Core () +executeOneStep _ _ _ _ = + throw (InternalError "the one-step-at-a-time emitter does not execute programs") + +export +codegenIdricOneStep : Codegen +codegenIdricOneStep = MkCG compileOneStep executeOneStep Nothing Nothing From 19b67dc151d819ab11d44fc834f2a53f7eda0945 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:42:21 -0400 Subject: [PATCH 13/80] Restore one-step handoff wrapper --- _/scripts/emit-one-step.sh | 84 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 84 insertions(+) create mode 100644 _/scripts/emit-one-step.sh diff --git a/_/scripts/emit-one-step.sh b/_/scripts/emit-one-step.sh new file mode 100644 index 0000000000..fe4f7591d4 --- /dev/null +++ b/_/scripts/emit-one-step.sh @@ -0,0 +1,84 @@ +#!/bin/sh +set -eu + +support_root=$(CDPATH='' cd -- "$(dirname -- "$0")/.." && pwd) +compiler="$support_root/build/exec/idris2" + +usage() { + printf 'usage: ./_/edric --emit-one-step SOURCE -o ARTIFACT\n' >&2 +} + +[ "$#" -eq 3 ] || { usage; exit 2; } +source=$1 +[ "$2" = "-o" ] || { usage; exit 2; } +artifact=$3 + +[ -f "$source" ] || { printf 'source not found: %s\n' "$source" >&2; exit 1; } +[ -x "$compiler" ] || { + printf 'compiler not found: %s (run ./_/edric bootstrap first)\n' "$compiler" >&2 + exit 1 +} + +sha256_file() { + if command -v sha256sum >/dev/null 2>&1; then + sha256sum "$1" | awk '{print $1}' + elif command -v shasum >/dev/null 2>&1; then + shasum -a 256 "$1" | awk '{print $1}' + else + printf 'need sha256sum or shasum for deterministic receipts\n' >&2 + exit 1 + fi +} + +artifact_dir=$(dirname -- "$artifact") +artifact_base=$(basename -- "$artifact") +mkdir -p "$artifact_dir" +output_dir=$(CDPATH='' cd -- "$artifact_dir" && pwd) +artifact_path="$output_dir/$artifact_base" +work_dir="$output_dir/.${artifact_base}.work" +body_name="$artifact_base.body" +body="$output_dir/$body_name" +rm -rf "$work_dir" +mkdir -p "$work_dir" +rm -f "$artifact_path" "$body" + +PATH="$support_root/.tools/bin:$PATH" +export PATH +IDRIS2_PREFIX="$support_root/build/env" +export IDRIS2_PREFIX +IDRIS2_PATH="$support_root/libs/prelude/build/ttc:$support_root/libs/base/build/ttc:$support_root/libs/network/build/ttc" +export IDRIS2_PATH + +"$compiler" \ + --cg idric-one-step \ + --build-dir "$work_dir/build" \ + --output-dir "$output_dir" \ + -o "$body_name" \ + "$source" + +first_line=$(sed -n '1p' "$body") +expected_body_header=$(printf 'EDRIC_ONE_STEP_BODY\t1') +[ "$first_line" = "$expected_body_header" ] || { + printf 'unexpected one-step compiler body header: %s\n' "$first_line" >&2 + exit 1 +} + +source_sha256=$(sha256_file "$source") +body_sha256=$(sha256_file "$body") +compiler_head=$(git -C "$support_root" rev-parse HEAD) + +{ + printf 'EDRIC_ONE_STEP\t1\n' + printf 'source_sha256\t%s\n' "$source_sha256" + printf 'compiler_head\tisomorphisms/Idric\t%s\n' "$compiler_head" + printf 'core_typecheck\tPASS\n' + printf 'representation\tidris2-anf-show-0.8.0\n' + printf 'body_sha256\t%s\n' "$body_sha256" + printf 'definitions_begin\n' + sed '1d' "$body" + printf 'definitions_end\n' + printf 'end\n' +} > "$artifact_path" + +rm -rf "$work_dir" +rm -f "$body" From 83bfa3f126d551723857db4ca870e1c3c2fe78a7 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:42:28 -0400 Subject: [PATCH 14/80] Add one-step handoff fixture --- _/examples/compiler-one-step/PrintX.idric | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 _/examples/compiler-one-step/PrintX.idric diff --git a/_/examples/compiler-one-step/PrintX.idric b/_/examples/compiler-one-step/PrintX.idric new file mode 100644 index 0000000000..936f6ea84e --- /dev/null +++ b/_/examples/compiler-one-step/PrintX.idric @@ -0,0 +1,4 @@ +module PrintX + +main : IO () +main = putChar 'X' From cea12b6cb82355e7e0b1a83124fbc3edc1f47b67 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:42:38 -0400 Subject: [PATCH 15/80] Test one-step handoff determinism --- _/scripts/test-one-step-emitter.sh | 44 ++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 _/scripts/test-one-step-emitter.sh diff --git a/_/scripts/test-one-step-emitter.sh b/_/scripts/test-one-step-emitter.sh new file mode 100644 index 0000000000..14523757dd --- /dev/null +++ b/_/scripts/test-one-step-emitter.sh @@ -0,0 +1,44 @@ +#!/bin/sh +set -eu + +support_root=$(CDPATH='' cd -- "$(dirname -- "$0")/.." && pwd) +source="$support_root/examples/compiler-one-step/PrintX.idric" +artifact_dir="$support_root/build/one-step-test" +artifact="$artifact_dir/PrintX.one-step" +artifact2="$artifact_dir/PrintX.second.one-step" +compiler_head=$(git -C "$support_root" rev-parse HEAD) + +rm -rf "$artifact_dir" +mkdir -p "$artifact_dir" + +sh "$support_root/scripts/emit-one-step.sh" "$source" -o "$artifact" +sh "$support_root/scripts/emit-one-step.sh" "$source" -o "$artifact2" + +cmp "$artifact" "$artifact2" + +expected_header=$(printf 'EDRIC_ONE_STEP\t1') +expected_source=$(printf 'source_sha256\t%s' "$(sha256sum "$source" | awk '{print $1}')") +expected_head=$(printf 'compiler_head\tisomorphisms/Idric\t%s' "$compiler_head") +expected_typecheck=$(printf 'core_typecheck\tPASS') +expected_representation=$(printf 'representation\tidris2-anf-show-0.8.0') +expected_definition=$(printf "PrintX.main = [0]: %%let v1 = ('X') in (Prelude.IO.prim__putChar(v1, v0))") + +[ "$(sed -n '1p' "$artifact")" = "$expected_header" ] +[ "$(sed -n '2p' "$artifact")" = "$expected_source" ] +[ "$(sed -n '3p' "$artifact")" = "$expected_head" ] +[ "$(sed -n '4p' "$artifact")" = "$expected_typecheck" ] +[ "$(sed -n '5p' "$artifact")" = "$expected_representation" ] +grep -Fx 'definitions_begin' "$artifact" >/dev/null +grep -Fx "$expected_definition" "$artifact" >/dev/null +grep -Fx 'definitions_end' "$artifact" >/dev/null +[ "$(tail -n 1 "$artifact")" = end ] + +body_hash=$(awk ' + /^definitions_begin$/ { inside=1; next } + /^definitions_end$/ { inside=0 } + inside { print } +' "$artifact" | sha256sum | awk '{print $1}') +recorded_body_hash=$(awk -F '\t' '$1 == "body_sha256" { print $2 }' "$artifact") +[ "$body_hash" = "$recorded_body_hash" ] + +printf 'one-step compiler handoff: PASS\n' From 0062d82f1aeb76a29825057411ad14d09cb0c4f7 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:42:51 -0400 Subject: [PATCH 16/80] Expose one-step handoff in current driver --- _/edric | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/_/edric b/_/edric index 7b9728ce73..26dcee1b3a 100755 --- a/_/edric +++ b/_/edric @@ -16,14 +16,16 @@ export PATH usage() { cat <<'USAGE' -usage: ./edric [scheme|bootstrap|test|all] - ./edric test --only TEST_FILTER +usage: ./_/edric [scheme|bootstrap|test|all] + ./_/edric test --only TEST_FILTER + ./_/edric --emit-one-step SOURCE -o ARTIFACT - scheme install the pinned threaded Chez Scheme under .tools - bootstrap install Chez Scheme, then bootstrap Idris 2 - test run the focused Edric handoff test with an existing build - or run one test selected by --only - all install Chez Scheme, bootstrap Idris 2, and run the handoff test + scheme install the pinned threaded Chez Scheme under .tools + bootstrap install Chez Scheme, then bootstrap Idris 2 + test run the focused Edric handoff test with an existing build + or run one test selected by --only + --emit-one-step typecheck SOURCE and emit the deterministic ANF handoff + all install Chez Scheme, bootstrap Idris 2, and run the handoff test With no command, all is used. USAGE @@ -51,6 +53,7 @@ smoke_test() { run_test idris2/basic/edric005 run_test idris2/basic/edric006 run_test idris2/basic/edric009 + sh "$repo_root/scripts/test-one-step-emitter.sh" } command=${1:-all} @@ -86,6 +89,10 @@ test) ;; esac ;; +--emit-one-step) + [ "$#" -eq 3 ] || { usage >&2; exit 2; } + exec sh "$repo_root/scripts/emit-one-step.sh" "$@" + ;; all) [ "$#" -eq 0 ] || { usage >&2; exit 2; } bootstrap From 8bb5da05ed4fef6573083f947f1b695eecc04de7 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:43:28 -0400 Subject: [PATCH 17/80] Preserve hash-command behavior --- Core/Options.idr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Core/Options.idr b/Core/Options.idr index 6a467b5d08..37c682efc4 100644 --- a/Core/Options.idr +++ b/Core/Options.idr @@ -283,7 +283,7 @@ defaultHashFn Nothing <- coreLift $ pathLookup ["sha256"] | Just p => pure $ Just p Nothing <- coreLift $ pathLookup ["openssl"] - | Just p => pure $ Just p ++ " sha256" + | Just p => pure $ Just $ p ++ " sha256" pure Nothing export From 4abdba534d41d31661c89d064722828583ab9038 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:51:57 -0400 Subject: [PATCH 18/80] Match one-step body hash contract --- _/scripts/test-one-step-emitter.sh | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/_/scripts/test-one-step-emitter.sh b/_/scripts/test-one-step-emitter.sh index 14523757dd..4881314576 100644 --- a/_/scripts/test-one-step-emitter.sh +++ b/_/scripts/test-one-step-emitter.sh @@ -6,6 +6,7 @@ source="$support_root/examples/compiler-one-step/PrintX.idric" artifact_dir="$support_root/build/one-step-test" artifact="$artifact_dir/PrintX.one-step" artifact2="$artifact_dir/PrintX.second.one-step" +body="$artifact_dir/PrintX.body" compiler_head=$(git -C "$support_root" rev-parse HEAD) rm -rf "$artifact_dir" @@ -33,11 +34,15 @@ grep -Fx "$expected_definition" "$artifact" >/dev/null grep -Fx 'definitions_end' "$artifact" >/dev/null [ "$(tail -n 1 "$artifact")" = end ] -body_hash=$(awk ' - /^definitions_begin$/ { inside=1; next } - /^definitions_end$/ { inside=0 } - inside { print } -' "$artifact" | sha256sum | awk '{print $1}') +{ + printf 'EDRIC_ONE_STEP_BODY\t1\n' + awk ' + /^definitions_begin$/ { inside=1; next } + /^definitions_end$/ { inside=0 } + inside { print } + ' "$artifact" +} > "$body" +body_hash=$(sha256sum "$body" | awk '{print $1}') recorded_body_hash=$(awk -F '\t' '$1 == "body_sha256" { print $2 }' "$artifact") [ "$body_hash" = "$recorded_body_hash" ] From 84273dfcda5a6d13e2250931f8d93d4156c51607 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:52:36 -0400 Subject: [PATCH 19/80] Preserve proven one-step wrapper behavior --- _/scripts/emit-one-step.sh | 100 ++++++++++++++++++------------------- 1 file changed, 48 insertions(+), 52 deletions(-) diff --git a/_/scripts/emit-one-step.sh b/_/scripts/emit-one-step.sh index fe4f7591d4..7da4eb15a2 100644 --- a/_/scripts/emit-one-step.sh +++ b/_/scripts/emit-one-step.sh @@ -5,66 +5,62 @@ support_root=$(CDPATH='' cd -- "$(dirname -- "$0")/.." && pwd) compiler="$support_root/build/exec/idris2" usage() { - printf 'usage: ./_/edric --emit-one-step SOURCE -o ARTIFACT\n' >&2 + echo "usage: ./_/edric --emit-one-step SOURCE -o ARTIFACT" >&2 + exit 2 } -[ "$#" -eq 3 ] || { usage; exit 2; } +[ "$#" -eq 3 ] || usage source=$1 -[ "$2" = "-o" ] || { usage; exit 2; } -artifact=$3 +case "$2" in + -o|--output) ;; + *) usage ;; +esac +output=$3 -[ -f "$source" ] || { printf 'source not found: %s\n' "$source" >&2; exit 1; } +[ -f "$source" ] || { echo "Idric one-step emitter: source not found: $source" >&2; exit 2; } [ -x "$compiler" ] || { - printf 'compiler not found: %s (run ./_/edric bootstrap first)\n' "$compiler" >&2 - exit 1 -} - -sha256_file() { - if command -v sha256sum >/dev/null 2>&1; then - sha256sum "$1" | awk '{print $1}' - elif command -v shasum >/dev/null 2>&1; then - shasum -a 256 "$1" | awk '{print $1}' - else - printf 'need sha256sum or shasum for deterministic receipts\n' >&2 - exit 1 - fi + echo "Idric one-step emitter: compiler is not bootstrapped; run ./_/edric bootstrap" >&2 + exit 2 } -artifact_dir=$(dirname -- "$artifact") -artifact_base=$(basename -- "$artifact") -mkdir -p "$artifact_dir" -output_dir=$(CDPATH='' cd -- "$artifact_dir" && pwd) -artifact_path="$output_dir/$artifact_base" -work_dir="$output_dir/.${artifact_base}.work" -body_name="$artifact_base.body" -body="$output_dir/$body_name" -rm -rf "$work_dir" -mkdir -p "$work_dir" -rm -f "$artifact_path" "$body" +caller_pwd=$(pwd) +source_dir=$(CDPATH='' cd -- "$(dirname -- "$source")" && pwd) +source_name=$(basename -- "$source") +source_path="$source_dir/$source_name" +case "$output" in + /*) output_path=$output ;; + *) output_path="$caller_pwd/$output" ;; +esac +output_dir=$(dirname -- "$output_path") +output_name=$(basename -- "$output_path") +mkdir -p "$output_dir" -PATH="$support_root/.tools/bin:$PATH" -export PATH -IDRIS2_PREFIX="$support_root/build/env" -export IDRIS2_PREFIX -IDRIS2_PATH="$support_root/libs/prelude/build/ttc:$support_root/libs/base/build/ttc:$support_root/libs/network/build/ttc" -export IDRIS2_PATH +body_name=".$output_name.body.$$" +body_path="$output_dir/$body_name" +tmp="$output_path.tmp.$$" +build_dir="$output_dir/.$output_name.build.$$" +mkdir -p "$build_dir" +trap 'rm -rf "$build_dir"; rm -f "$body_path" "$tmp"' EXIT HUP INT TERM -"$compiler" \ - --cg idric-one-step \ - --build-dir "$work_dir/build" \ - --output-dir "$output_dir" \ - -o "$body_name" \ - "$source" +idric_library_path="$support_root/libs/prelude/build/ttc:$support_root/libs/base/build/ttc:$support_root/libs/linear/build/ttc:$support_root/libs/network/build/ttc:$support_root/libs/contrib/build/ttc:$support_root/libs/test/build/ttc:" +( + cd "$source_dir" + PATH="$support_root/.tools/bin:$PATH" \ + IDRIS2_PREFIX="$support_root/bootstrap-build" \ + IDRIS2_PATH="$idric_library_path" \ + "$compiler" --cg idric-one-step --build-dir "$build_dir" \ + --output-dir "$output_dir" -o "$body_name" "$source_name" +) -first_line=$(sed -n '1p' "$body") -expected_body_header=$(printf 'EDRIC_ONE_STEP_BODY\t1') -[ "$first_line" = "$expected_body_header" ] || { - printf 'unexpected one-step compiler body header: %s\n' "$first_line" >&2 +[ "$(head -n 1 "$body_path")" = "$(printf 'EDRIC_ONE_STEP_BODY\t1')" ] || { + echo "Idric one-step emitter: compiler returned the wrong artifact body" >&2 exit 1 } -source_sha256=$(sha256_file "$source") -body_sha256=$(sha256_file "$body") +set -- $(sha256sum "$source_path") +source_sha256=$1 +set -- $(sha256sum "$body_path") +body_sha256=$1 compiler_head=$(git -C "$support_root" rev-parse HEAD) { @@ -75,10 +71,10 @@ compiler_head=$(git -C "$support_root" rev-parse HEAD) printf 'representation\tidris2-anf-show-0.8.0\n' printf 'body_sha256\t%s\n' "$body_sha256" printf 'definitions_begin\n' - sed '1d' "$body" + tail -n +2 "$body_path" printf 'definitions_end\n' printf 'end\n' -} > "$artifact_path" - -rm -rf "$work_dir" -rm -f "$body" +} > "$tmp" +mv "$tmp" "$output_path" +rm -rf "$build_dir" +trap - EXIT HUP INT TERM From 5a29d0d38bd701f87ff688d428d9cfa748e76c63 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 4 Sep 2026 18:55:23 -0400 Subject: [PATCH 20/80] Exercise public one-step handoff surface --- _/scripts/test-one-step-emitter.sh | 60 +++++++++++------------------- 1 file changed, 22 insertions(+), 38 deletions(-) diff --git a/_/scripts/test-one-step-emitter.sh b/_/scripts/test-one-step-emitter.sh index 4881314576..b157586f71 100644 --- a/_/scripts/test-one-step-emitter.sh +++ b/_/scripts/test-one-step-emitter.sh @@ -3,47 +3,31 @@ set -eu support_root=$(CDPATH='' cd -- "$(dirname -- "$0")/.." && pwd) source="$support_root/examples/compiler-one-step/PrintX.idric" -artifact_dir="$support_root/build/one-step-test" -artifact="$artifact_dir/PrintX.one-step" -artifact2="$artifact_dir/PrintX.second.one-step" -body="$artifact_dir/PrintX.body" -compiler_head=$(git -C "$support_root" rev-parse HEAD) - -rm -rf "$artifact_dir" -mkdir -p "$artifact_dir" - -sh "$support_root/scripts/emit-one-step.sh" "$source" -o "$artifact" -sh "$support_root/scripts/emit-one-step.sh" "$source" -o "$artifact2" +temporary=$(mktemp -d) +trap 'rm -rf "$temporary"' EXIT HUP INT TERM -cmp "$artifact" "$artifact2" - -expected_header=$(printf 'EDRIC_ONE_STEP\t1') -expected_source=$(printf 'source_sha256\t%s' "$(sha256sum "$source" | awk '{print $1}')") -expected_head=$(printf 'compiler_head\tisomorphisms/Idric\t%s' "$compiler_head") -expected_typecheck=$(printf 'core_typecheck\tPASS') -expected_representation=$(printf 'representation\tidris2-anf-show-0.8.0') -expected_definition=$(printf "PrintX.main = [0]: %%let v1 = ('X') in (Prelude.IO.prim__putChar(v1, v0))") - -[ "$(sed -n '1p' "$artifact")" = "$expected_header" ] -[ "$(sed -n '2p' "$artifact")" = "$expected_source" ] -[ "$(sed -n '3p' "$artifact")" = "$expected_head" ] -[ "$(sed -n '4p' "$artifact")" = "$expected_typecheck" ] -[ "$(sed -n '5p' "$artifact")" = "$expected_representation" ] -grep -Fx 'definitions_begin' "$artifact" >/dev/null -grep -Fx "$expected_definition" "$artifact" >/dev/null -grep -Fx 'definitions_end' "$artifact" >/dev/null -[ "$(tail -n 1 "$artifact")" = end ] +first="$temporary/print-x.first.one-step" +second="$temporary/print-x.second.one-step" +"$support_root/edric" --emit-one-step "$source" -o "$first" +"$support_root/edric" --emit-one-step "$source" -o "$second" +cmp "$first" "$second" +source_sha=$(sha256sum "$source" | cut -d' ' -f1) +compiler_head=$(git -C "$support_root" rev-parse HEAD) +test "$(head -n 1 "$first")" = "$(printf 'EDRIC_ONE_STEP\t1')" +grep -Fx "$(printf 'source_sha256\t%s' "$source_sha")" "$first" +grep -Fx "$(printf 'compiler_head\tisomorphisms/Idric\t%s' "$compiler_head")" "$first" +grep -Fx "$(printf 'core_typecheck\tPASS')" "$first" +grep -Fx "$(printf 'representation\tidris2-anf-show-0.8.0')" "$first" +grep -F "PrintX.main = [0]: %let v1 = ('X') in (Prelude.IO.prim__putChar(v1, v0))" "$first" +test "$(tail -n 1 "$first")" = end + +body="$temporary/body" { printf 'EDRIC_ONE_STEP_BODY\t1\n' - awk ' - /^definitions_begin$/ { inside=1; next } - /^definitions_end$/ { inside=0 } - inside { print } - ' "$artifact" + sed -n '/^definitions_begin$/,/^definitions_end$/p' "$first" | sed '1d;$d' } > "$body" -body_hash=$(sha256sum "$body" | awk '{print $1}') -recorded_body_hash=$(awk -F '\t' '$1 == "body_sha256" { print $2 }' "$artifact") -[ "$body_hash" = "$recorded_body_hash" ] +body_sha=$(sha256sum "$body" | cut -d' ' -f1) +grep -Fx "$(printf 'body_sha256\t%s' "$body_sha")" "$first" -printf 'one-step compiler handoff: PASS\n' +printf '%s\n' 'Idric compiler one-step emitter: PASS' From ac8f8b4b4d19eba61d1a50b340fea0751760583d Mon Sep 17 00:00:00 2001 From: i Date: Sat, 5 Sep 2026 17:04:54 -0400 Subject: [PATCH 21/80] Restore upstream BSD-3-Clause license --- LICENSE | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) create mode 100644 LICENSE diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000000..0685846f47 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright (c) 2020 Edwin Brady + School of Computer Science, University of St Andrews +All rights reserved. + +This code is derived from software written by Edwin Brady +(ecb10@st-andrews.ac.uk). + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. None of the names of the copyright holders may be used to endorse + or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +*** End of disclaimer. *** From 0ee85259596f9590c72f01e9d8ec817bf700a49c Mon Sep 17 00:00:00 2001 From: i Date: Sat, 5 Sep 2026 17:06:54 -0400 Subject: [PATCH 22/80] Export Compiler.IdricOneStep through installed API --- _/idris2api.ipkg | 1 + 1 file changed, 1 insertion(+) diff --git a/_/idris2api.ipkg b/_/idris2api.ipkg index a0f4831fe1..dbd0a1e346 100644 --- a/_/idris2api.ipkg +++ b/_/idris2api.ipkg @@ -13,6 +13,7 @@ modules = Compiler.Common, Compiler.CompileExpr, Compiler.Generated, + Compiler.IdricOneStep, Compiler.Inline, Compiler.LambdaLift, Compiler.NoMangle, From d49d29ba949705e5a78546cded3475e97e724020 Mon Sep 17 00:00:00 2001 From: i Date: Sat, 5 Sep 2026 20:04:36 -0400 Subject: [PATCH 23/80] Restore top-level edric compatibility entrypoint --- edric | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 edric diff --git a/edric b/edric new file mode 100644 index 0000000000..9e695e680d --- /dev/null +++ b/edric @@ -0,0 +1,40 @@ +#!/bin/sh +set -eu + +repo_root=$(CDPATH='' cd -- "$(dirname -- "$0")" && pwd) +hidden_root=$repo_root/_ + +[ -x "$hidden_root/edric" ] || { + printf '%s\n' 'edric: _/edric is missing or not executable' >&2 + exit 127 +} + +sh "$hidden_root/edric" "$@" + +# Keep build-system state under _/, while preserving stable top-level paths +# for Catfood and for people invoking the compiler directly. +link_hidden_output() { + name=$1 + target=_/$name + source=$repo_root/$target + destination=$repo_root/$name + + [ -e "$source" ] || return 0 + if [ -L "$destination" ]; then + ln -sfn "$target" "$destination" + elif [ ! -e "$destination" ]; then + ln -s "$target" "$destination" + fi +} + +link_hidden_output .tools +link_hidden_output bootstrap-build +link_hidden_output build + +if [ -x "$hidden_root/build/exec/idris2" ]; then + if [ -L "$repo_root/idris2" ]; then + ln -sfn _/build/exec/idris2 "$repo_root/idris2" + elif [ ! -e "$repo_root/idris2" ]; then + ln -s _/build/exec/idris2 "$repo_root/idris2" + fi +fi From 8bdc1d0ad007e8884fa2e0674b84bf4f044bdcb3 Mon Sep 17 00:00:00 2001 From: i Date: Sat, 5 Sep 2026 20:11:51 -0400 Subject: [PATCH 24/80] Test executable root edric compatibility --- .github/workflows/ci-source-layout.yml | 7 +++++++ edric | 0 2 files changed, 7 insertions(+) mode change 100644 => 100755 edric diff --git a/.github/workflows/ci-source-layout.yml b/.github/workflows/ci-source-layout.yml index a373e3f1df..7539590213 100644 --- a/.github/workflows/ci-source-layout.yml +++ b/.github/workflows/ci-source-layout.yml @@ -18,3 +18,10 @@ jobs: test -d TTImp test -L _/src test "$(readlink _/src)" = ".." + - name: Verify top-level edric compatibility entrypoint + shell: sh + run: | + test -x edric + dash -n edric + sh -n edric + ./edric --help | grep -F 'usage: ./_/edric' diff --git a/edric b/edric old mode 100644 new mode 100755 From cf8d159d1df4eb0c189ab18333cfce912bf42cd7 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 08:53:40 -0400 Subject: [PATCH 25/80] =?UTF-8?q?Document=20provisional=20Idri=C3=A7=20sou?= =?UTF-8?q?rce=20rules?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- STYLE.md | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 STYLE.md diff --git a/STYLE.md b/STYLE.md new file mode 100644 index 0000000000..11e14a347d --- /dev/null +++ b/STYLE.md @@ -0,0 +1,61 @@ +# Idriç source style + +This file records Idriç rules that have actually been decided. It is deliberately +incomplete. The language and its programming style are still being worked out +with a human in the loop. + +Valid Idris is not automatically good Idriç. Do not fill gaps in this document +by reverting to conventional Idris, Haskell, or generic functional-programming +style. + +## Established mechanical rules + +### `Nat` is prohibited in new Idriç-facing source + +Use `Number` when the program means an ordinary number or count. + +If nonnegativity, sign, bounds, units, or another restriction are part of the +meaning, do not reach for `Nat` as an implementation-shaped substitute. Give +that meaning a semantic restricted type. + +Do not mechanically replace every historical `Nat` in inherited Idris code. +This rule prevents new Idriç source from adding more of it. + +### `Vect` is prohibited in new Idriç-facing source + +Use `List` when the length is not part of what the program means. + +If a length or shape really is semantically important, preserve that fact with +a domain-specific collection or restriction. Do not use generic `Vect` merely +because Idris makes it available, and do not blindly replace `Vect` with `List` +when doing so would erase meaning. + +### Use `snake_case`, not lower camel case + +A newly introduced lowerCamelCase identifier is a style canary. It often means +the surrounding code was written from Idris/Haskell habit rather than from the +Idriç design. + +The mechanical check warns rather than rewrites it. When the warning appears, +inspect the whole declaration and its vocabulary before deciding the correct +`snake_case` name. + +### Use real arrows in Idriç-facing notation + +Use `→` and `←`, not ASCII `->` and `<-`, when writing Idriç-facing source. + +An ASCII arrow is also a style canary. Do not treat the warning as a request for +blind character substitution; re-check the declaration for other inherited +Idris/Haskell defaults at the same time. + +## Human corrections are part of the specification + +There is not yet a blessed directory of canonical "good Idriç" examples. +Current work in Idriç, ICU, ish, Idric-Net, and related repositories is still +being corrected and refined. + +When the user corrects generated code, treat the correction as evidence about +the language style. Repeated corrections should become explicit rules or +mechanical checks when the rule is clear enough. + +Do not declare an example canonical without explicit human approval. From 7d7104c6d167048d291ea346fccf25166da7852f Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 08:53:48 -0400 Subject: [PATCH 26/80] =?UTF-8?q?Add=20Idri=C3=A7=20agent=20style=20guardr?= =?UTF-8?q?ails?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- AGENTS.md | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 AGENTS.md diff --git a/AGENTS.md b/AGENTS.md new file mode 100644 index 0000000000..2793f051dd --- /dev/null +++ b/AGENTS.md @@ -0,0 +1,39 @@ +# Idriç agent instructions + +Read [STYLE.md](STYLE.md) before writing or reviewing Idriç-facing source. +Also read `_/AGENTS.md` for repository and branch rules. + +The repository contains a large inherited Idris codebase. Its existence is not +permission to reproduce Idris/Haskell style in new Idriç work. + +## Hard stops + +Do not introduce `Nat` or `Vect` in new Idriç-facing source. + +- For `Nat`, first ask what the value means. Use `Number` for an ordinary number + or count. If a restriction such as nonnegativity, a range, units, or another + domain property matters, represent that semantic restriction explicitly. +- For `Vect`, use `List` when length is not part of the meaning. If length or + shape matters, represent that semantic fact explicitly instead of defaulting + to generic `Vect`. + +## Style canaries + +Treat newly introduced lowerCamelCase identifiers or ASCII `->` / `<-` arrows +as evidence that you may have fallen back to Idris/Haskell defaults. + +Do not merely make the mechanical substitution and continue. Re-read +`STYLE.md`, re-read the surrounding declarations, and reconsider names, types, +structure, and vocabulary as a whole. If conversation history containing human +corrections is available, review it. Inspect relevant recent Idriç-family work +when useful, but do not assume any existing file is canonical unless the user +has said so. + +Use `snake_case` and real `→` / `←` arrows in Idriç-facing source. + +## Human-in-the-loop style development + +There is no finished corpus of approved "good Idriç" examples yet. The user's +corrections determine the style while it is being developed. When a correction +recurs and becomes unambiguous, prefer recording or enforcing it rather than +making the same default-style mistake again. From 3edff41f3a2530ab84396ad30b3680e434ee27e8 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 08:53:59 -0400 Subject: [PATCH 27/80] =?UTF-8?q?Add=20Idri=C3=A7=20style=20drift=20checke?= =?UTF-8?q?r?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- _/style/check_added_source | 74 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) create mode 100644 _/style/check_added_source diff --git a/_/style/check_added_source b/_/style/check_added_source new file mode 100644 index 0000000000..979bef705e --- /dev/null +++ b/_/style/check_added_source @@ -0,0 +1,74 @@ +#!/bin/sh +set -eu + +if [ "$#" -lt 1 ] || [ "$#" -gt 2 ]; then + echo "usage: $0 BASE [HEAD]" >&2 + exit 2 +fi + +base=$1 +head=${2:-HEAD} + +# Check only lines added by this change. The repository still contains a large +# inherited Idris codebase; this gate prevents new Idriç-facing source from +# drifting back toward those defaults without demanding an unrelated rewrite. +git diff --unified=0 --no-color "$base" "$head" -- '*.idr' '*.idric' | +awk ' +function annotation(level, message) { + if (path == "") { + print level ": " message > "/dev/stderr" + return + } + + printf "::%s file=%s,line=%d::%s\n", level, path, line, message > "/dev/stderr" +} + +function source_code(added, p) { + # Remove ordinary Idris/Idriç line comments. This deliberately does not try + # to parse the language; the check is a small drift detector, not a compiler. + p = index(added, "--") + if (p > 0) + return substr(added, 1, p - 1) + return added +} + +/^\+\+\+ b\// { + path = substr($0, 7) + next +} + +/^@@ / { + if (match($0, /\+[0-9]+/)) + line = substr($0, RSTART + 1, RLENGTH - 1) + 0 + next +} + +/^\+/ && !/^\+\+\+/ { + added = substr($0, 2) + code = source_code(added) + + if (code ~ /(^|[^[:alnum:]_])Nat([^[:alnum:]_]|$)/) { + annotation("error", "Idriç source must not introduce Nat. Use Number for an ordinary number/count; if nonnegativity or a range is meaningful, use a semantic restricted type.") + errors++ + } + + if (code ~ /(^|[^[:alnum:]_])Vect([^[:alnum:]_]|$)/) { + annotation("error", "Idriç source must not introduce Vect. Use List when length is not part of the meaning; if length matters, use a semantic collection/restriction rather than generic Vect.") + errors++ + } + + if (code ~ /(^|[^[:alnum:]_])[a-z][[:alnum:]_]*[A-Z][[:alnum:]_]*([^[:alnum:]_]|$)/) + annotation("warning", "lowerCamelCase is an Idriç style canary. Do not merely rename the token: re-read STYLE.md and the surrounding design, then use snake_case if this identifier belongs in Idriç-facing code.") + + if (code ~ /->|<-/) + annotation("warning", "ASCII arrows are an Idriç style canary. Re-check the design rather than applying a blind replacement; Idriç-facing notation uses real arrows such as → and ←.") + + line++ + next +} + +END { + if (errors > 0) + exit 1 +} +' From da8da2e5aa3633a5291b5b06b93c4796e324beb3 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 08:54:17 -0400 Subject: [PATCH 28/80] =?UTF-8?q?Run=20Idri=C3=A7=20style=20check=20on=20e?= =?UTF-8?q?very=20change?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/ci_idric_style.yml | 40 ++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 .github/workflows/ci_idric_style.yml diff --git a/.github/workflows/ci_idric_style.yml b/.github/workflows/ci_idric_style.yml new file mode 100644 index 0000000000..d8e9963419 --- /dev/null +++ b/.github/workflows/ci_idric_style.yml @@ -0,0 +1,40 @@ +name: Idriç source-style drift check + +on: + push: + pull_request: + +permissions: + contents: read + +jobs: + style: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + with: + fetch-depth: 0 + - name: Check newly added Idriç source + shell: sh + env: + EVENT_NAME: ${{ github.event_name }} + PR_BASE_SHA: ${{ github.event.pull_request.base.sha }} + PUSH_BEFORE_SHA: ${{ github.event.before }} + run: | + base="$PUSH_BEFORE_SHA" + + if [ "$EVENT_NAME" = "pull_request" ]; then + base="$PR_BASE_SHA" + fi + + case "$base" in + ""|0000000000000000000000000000000000000000) + base="$(git rev-parse HEAD^)" + ;; + esac + + if ! git cat-file -e "$base^{commit}" 2>/dev/null; then + base="$(git rev-parse HEAD^)" + fi + + sh _/style/check_added_source "$base" HEAD From 1a062ffc5d5ab78a23d95d362c5569a69d16dade Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 08:54:32 -0400 Subject: [PATCH 29/80] =?UTF-8?q?Point=20repository=20agents=20to=20Idri?= =?UTF-8?q?=C3=A7=20style=20rules?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- _/AGENTS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/_/AGENTS.md b/_/AGENTS.md index 7c04664e90..2d48ab91fe 100644 --- a/_/AGENTS.md +++ b/_/AGENTS.md @@ -1,5 +1,9 @@ # Idriç repository rules +Read [../STYLE.md](../STYLE.md) before writing or reviewing Idriç-facing source. +`STYLE.md` is the source-style authority; this file is operational repository +guidance. + Read [EDRIC.md](EDRIC.md) and [BRANCHES.md](BRANCHES.md) before changing this repository. From 3de44a89960025e73f9d13223dd6c1b1e61503fe Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 09:15:23 -0400 Subject: [PATCH 30/80] =?UTF-8?q?Document=20Idri=C3=A7=20source=20and=20bo?= =?UTF-8?q?otstrap=20style?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- STYLE.md | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100644 STYLE.md diff --git a/STYLE.md b/STYLE.md new file mode 100644 index 0000000000..4bda74d2a5 --- /dev/null +++ b/STYLE.md @@ -0,0 +1,89 @@ +# Idriç source style + +This repository contains two languages at once. Files ending in `.idric` show +the Idriç language being designed. Files ending in `.idr` implement the +bootstrap compiler and preserve the Idris 2 compatibility surface. Do not make +the first look like renamed Idris, and do not mechanically restyle the second +as though its external and bootstrap names were Idriç names. + +## Read from purpose into mechanism + +Application and example entry points explain what the program means before +showing parsing, monadic plumbing, foreign calls, or backend machinery. Order +operations by human purpose. Put concrete algorithms and target-specific +implementations in descriptively named files below that layer; keep small +aggregation files limited to the operations their caller needs. + +Compiler directives are mechanism. `.idric` source is total by default, so it +does not begin with `%default total`. Use an explicit function-level or file +directive only when the source deliberately chooses another totality contract, +and explain why. `public export` is for an API that downstream modules must be +able to re-export; it is not a ceremonial prefix for every definition. + +## Idriç vocabulary and syntax + +- Use `snake_case` for names under our control and prefer complete domain words + to conventional Haskell abbreviations. +- Use `Number`, not `Nat` or the older migration spelling `ℕ`, in new `.idric` + source. Use `Text`, not `String`, for decoded character text. Both lower to + inherited representations inside the bootstrap compiler. +- Use a semantic type instead of `Number`, `Text`, a raw integer, `Bits8`, or a + flag when the value has narrower operations or invariants. +- Use `List` for an ordinary sequence, `SizedList` or `ListOfLength` when length + belongs in the type, and `Array` for contiguous indexed storage. Reserve + `Vector` for a mathematical vector-space value. `Vect` survives only at an + explicit Idris compatibility boundary. +- Use the canonical Unicode spellings `→`, `←`, and `⇒` in fresh `.idric` + source. Use `$` when it removes unhelpful nested parentheses, not as a reason + to remove readable grouping. +- Avoid gratuitous currying, bare-application chains, constructor-led program + descriptions, and implementation types in domain vocabulary. + +The general name for a number that may be positive or negative is still +unresolved. Prefer a domain name where there is one and do not introduce a new +unrestricted wrapper merely to avoid inherited spelling. + +## Semantic boundaries + +Receive and validate raw data once, retain its source identity and semantic +meaning, and lower it explicitly at the next raw boundary. Distinguish text +from bytes, paths from arbitrary text, units and widths, protocol states, and +structured results from Boolean or integer projections. Prefer a named record +when tuple positions have different meanings. + +Keep target-neutral checked forms above target-specific lowering. C/RefC is not +a universal backend escape hatch. A direct DEX, Wasm, machine-code, GPU, or +other backend must generate that target in its production path and fail closed +for unsupported semantics. DEX and ARM/Thumb work are sibling backend lines; +do not give one the other's Git ancestry, modules, fixtures, or acceptance +claims. + +Preserve an explicitly chosen numeric width through checking, IR, and lowering. +Float16 is the ordinary source default; Float32 remains deliberate, and neither +is silently carried as or narrowed from an unrelated host `Double`. + +## Repository layout and provenance + +The maintained compiler source is exposed at the repository root. Build +machinery, the pinned bootstrap tree, upstream libraries, inherited tests, and +generated output live under `_`. Do not style those imported strata as newly +written Idriç. New language examples use `.idric`; Idris bootstrap and external +compatibility source remains `.idr`. + +Keep `.gitattributes` accurate so `.idric` is recognized and generated, +vendored, bootstrap, and foreign material does not distort repository language +statistics. Retain source/specification provenance for unusual inherited or +foreign mechanisms without copying their architecture into new code. + +## Comments and acceptance + +Name semantic constants and explain non-obvious numeric values, opcodes, bit +patterns, representation conversions, and backend restrictions. Comments say +why a mechanism exists and what a boundary guarantees. + +Every language change needs a focused `.idric` acceptance case and a matching +`.idr` compatibility case when tokenization or parsing could affect Idris. +Acceptance must identify the exact compiler revision, prove the intended source +or artifact structure, and run behavior at the claimed boundary. Use `PASS`, +`FAIL`, `SKIP`, and `BLOCKED` accurately; an emulator or stale branch is not a +device or current-head receipt. From 0ca1c138539ce6cdbcf406f6c97ddf5531555fb1 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 09:16:33 -0400 Subject: [PATCH 31/80] =?UTF-8?q?Make=20Number=20and=20Text=20native=20Idr?= =?UTF-8?q?i=C3=A7=20vocabulary?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Idris/ProcessIdr.idr | 29 ++++++++++++++++--- Parser/Source.idr | 2 ++ _/EDRIC.md | 25 ++++++++++++---- .../EuclideanGeometry.idric | 15 +++++----- .../MathematicalSpaces.idric | 27 +++++++++-------- .../NamedFacts.idric | 11 ++++--- .../PresheafRestriction.idric | 1 - .../unified-higher-mathematics/Tests.idric | 5 ++-- .../TopologyFacts.idric | 29 +++++++++---------- .../exercise/Main.idric | 6 ++-- .../solution/Main.idric | 6 ++-- .../exercise/Main.idric | 4 +-- .../solution/Main.idric | 4 +-- .../exercise/Main.idric | 6 ++-- .../solution/Main.idric | 6 ++-- .../04-equality-proofs/exercise/Main.idric | 4 +-- .../04-equality-proofs/solution/Main.idric | 4 +-- .../exercise/Main.idric | 4 +-- .../solution/Main.idric | 4 +-- .../exercise/Main.idric | 4 +-- .../solution/Main.idric | 4 +-- .../07-erased-arguments/exercise/Main.idric | 4 +-- .../07-erased-arguments/solution/Main.idric | 4 +-- .../08-linear-arguments/exercise/Main.idric | 2 -- .../08-linear-arguments/solution/Main.idric | 2 -- .../exercise/Main.idric | 4 +-- .../solution/Main.idric | 4 +-- .../exercise/Main.idric | 6 ++-- .../solution/Main.idric | 6 ++-- .../11-source-boundaries/exercise/Main.idric | 6 ++-- .../11-source-boundaries/solution/Main.idric | 6 ++-- _/koans/12-wegert-model/exercise/Main.idric | 14 ++++----- _/koans/12-wegert-model/solution/Main.idric | 14 ++++----- .../idris2/basic/edric002/WegertSource.idric | 2 +- _/tests/idris2/basic/edric003/Main.idric | 8 ++--- .../idris2/basic/edric003/WegertTouch.idric | 6 ++-- _/tests/idris2/basic/edric005/Main.idric | 2 +- 37 files changed, 136 insertions(+), 154 deletions(-) diff --git a/Idris/ProcessIdr.idr b/Idris/ProcessIdr.idr index c6ae6ec9b3..91a6f02b86 100644 --- a/Idris/ProcessIdr.idr +++ b/Idris/ProcessIdr.idr @@ -42,6 +42,24 @@ import System.File %default covering +-- Idriç treats totality as the ordinary source rule. The inherited Idris +-- directive remains available when a file deliberately needs a different +-- requirement, but fresh .idric programs do not need compiler policy at the +-- top of every source file. +with_idric_source_totality : + {auto c : Ref Ctxt Defs} -> String -> Core a -> Core a +with_idric_source_totality source_file operation = + if isSuffixOf ".idric" source_file + then do + prior_requirement <- getDefaultTotalityOption + setDefaultTotalityOption Total + result <- catch operation $ \error => do + setDefaultTotalityOption prior_requirement + throw error + setDefaultTotalityOption prior_requirement + pure result + else operation + -- If we're on an incremental codegen, check to see if the ttc was -- built with incremental. export @@ -387,10 +405,13 @@ processMod sourceFileName ttcFileName msg sourcecode origin -- defs <- get Ctxt -- traverse (\x => setVisibility emptyFC x Private) (hiddenNames defs) setNS (miAsNamespace ns) - errs <- logTime 2 "Processing decls" $ - processDecls (decls mod) - totErrs <- logTime 3 ("Totality check overall") - getTotalityErrors + (errs, totErrs) <- + with_idric_source_totality sourceFileName $ do + declaration_errors <- logTime 2 "Processing decls" $ + processDecls (decls mod) + totality_errors <- logTime 3 "Totality check overall" $ + getTotalityErrors + pure (declaration_errors, totality_errors) let errs = errs ++ totErrs -- coreLift $ gc diff --git a/Parser/Source.idr b/Parser/Source.idr index 40534cf52e..78eab645c3 100644 --- a/Parser/Source.idr +++ b/Parser/Source.idr @@ -16,6 +16,8 @@ import System.File canonicalizeIdricToken : Token -> Token canonicalizeIdricToken (Ident "choice") = Keyword "choice" +canonicalizeIdricToken (Ident "Number") = Ident "Nat" +canonicalizeIdricToken (Ident "Text") = Ident "String" canonicalizeIdricToken (Ident "ℕ") = Ident "Nat" canonicalizeIdricToken tok = tok diff --git a/_/EDRIC.md b/_/EDRIC.md index 06866e7cf9..5178634fa8 100644 --- a/_/EDRIC.md +++ b/_/EDRIC.md @@ -22,9 +22,20 @@ Use ordinary, current Idris 2 to implement Edric until an Edric change is itself The first Edric-specific syntax is the storage-neutral `choice` declaration described below. The compiler remains implemented in ordinary Idris 2. -## Natural-number vocabulary +## Number and text vocabulary -Idriç source spells the natural-number type `ℕ`. In a `.idric` file the frontend lowers `ℕ` to the inherited Idris 2 `Nat` internally; ordinary `.idr` source remains unchanged. `Nat` therefore remains an implementation and compatibility spelling, not the spelling for new Idriç APIs, examples, or teaching material. +Idriç source spells the unrestricted nonnegative whole-number type `Number` and +decoded character text `Text`. In a `.idric` file the frontend lowers those +names to the inherited Idris 2 bootstrap representations. Ordinary `.idr` +source remains unchanged. The inherited names are implementation and +compatibility spellings, not names for new Idriç APIs, examples, or teaching +material. + +`Number` and `Text` describe general language values. Code should still use a +more specific semantic type—source location, byte count, path, protocol field, +and so on—when operations or invariants differ. The older `ℕ` input spelling is +accepted temporarily so existing Idriç source can migrate without a flag day; +it is not the current spelling for new source. ## Data-structure vocabulary @@ -52,9 +63,9 @@ snake_case names: ```idris choice existing_touch_target one_of - fixed_value ℕ - zero ℕ - pole ℕ + fixed_value Number + zero Number + pole Number choice touch_beginning one_of near_existing existing_touch_target @@ -205,7 +216,9 @@ A new thread working on Edric should: - Idriç source extension: `.idric`; `.idr` remains accepted for Idris compatibility. - Storage-neutral, lower snake_case `choice ... one_of` syntax: implemented for `.idric` only. - Ordinary `.idr` use of `choice` and `one_of` as identifiers: preserved and regression-tested. -- Idriç source spells natural numbers `ℕ`; the frontend lowers that spelling to inherited Idris 2 `Nat` internally. +- Idriç source spells nonnegative whole numbers `Number` and decoded character + text `Text`; the frontend lowers both to inherited bootstrap representations. +- The older `ℕ` spelling remains a migration alias, not the current spelling. - Idriç source accepts `→`, `⇒`, `←`, and `≤` as compact aliases for `->`, `=>`, `<-`, and `<=`; the ASCII spellings remain accepted. - The aliases are filename-scoped to `.idric`; ordinary `.idr` Unicode identifiers remain unchanged. - Canonical Unicode pretty-printing is not yet claimed by this input-syntax slice. diff --git a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric index 29cdb8ae59..3e7ee763dd 100644 --- a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric +++ b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric @@ -2,7 +2,6 @@ module EuclideanGeometry import MathematicalSpaces -%default total %unbound_implicits off -- A finite coordinate space does not acquire a dot product merely from its @@ -11,7 +10,7 @@ import MathematicalSpaces public export data EuclideanStructure : FiniteSpace -> Type where StandardCoordinate : - {rank : ℕ} -> + {rank : Number} -> {name : SpaceName rank} -> EuclideanStructure (NamedFiniteSpace name) @@ -201,14 +200,14 @@ data OrthogonalTransform : {structure : EuclideanStructure space} -> OrthogonalTransform structure Preserving FirstAxisReflectionTransform : - {n : ℕ} -> + {n : Number} -> {name : SpaceName (S n)} -> OrthogonalTransform {space = NamedFiniteSpace name} StandardCoordinate Reversing FirstPlaneQuarterTurnTransform : - {n : ℕ} -> + {n : Number} -> {name : SpaceName (S (S n))} -> OrthogonalTransform {space = NamedFiniteSpace name} @@ -237,7 +236,7 @@ data SpecialOrthogonal : public export firstAxisReflection : - {n : ℕ} -> + {n : Number} -> {name : SpaceName (S n)} -> (structure : EuclideanStructure (NamedFiniteSpace name)) -> OrthogonalTransform structure Reversing @@ -245,7 +244,7 @@ firstAxisReflection StandardCoordinate = FirstAxisReflectionTransform public export firstPlaneQuarterTurn : - {n : ℕ} -> + {n : Number} -> {name : SpaceName (S (S n))} -> (structure : EuclideanStructure (NamedFiniteSpace name)) -> SpecialOrthogonal structure @@ -355,7 +354,7 @@ applySpecialOrthogonalExact (InSO transform) vector = -- the connected OrthogonalTransform evaluator. public export applyFirstAxisReflection : - {n : ℕ} -> + {n : Number} -> {name : SpaceName (S n)} -> (structure : EuclideanStructure (NamedFiniteSpace name)) -> ExactVectorSample (NamedFiniteSpace name) -> @@ -365,7 +364,7 @@ applyFirstAxisReflection structure = public export applyFirstPlaneQuarterTurn : - {n : ℕ} -> + {n : Number} -> {name : SpaceName (S (S n))} -> (structure : EuclideanStructure (NamedFiniteSpace name)) -> ExactVectorSample (NamedFiniteSpace name) -> diff --git a/_/examples/unified-higher-mathematics/MathematicalSpaces.idric b/_/examples/unified-higher-mathematics/MathematicalSpaces.idric index 0aec4ce7d7..ad02a976db 100644 --- a/_/examples/unified-higher-mathematics/MathematicalSpaces.idric +++ b/_/examples/unified-higher-mathematics/MathematicalSpaces.idric @@ -1,6 +1,5 @@ module MathematicalSpaces -%default total %unbound_implicits off -- This module is the small common semantic core shared by the Euclidean, @@ -9,7 +8,7 @@ module MathematicalSpaces -- Rank equality alone is still not space equality. public export -data SpaceName : ℕ -> Type where +data SpaceName : Number -> Type where PlaneName : SpaceName 2 ImagePlaneName : SpaceName 2 RealThreeName : SpaceName 3 @@ -17,10 +16,10 @@ data SpaceName : ℕ -> Type where public export data FiniteSpace : Type where - NamedFiniteSpace : {rank : ℕ} -> SpaceName rank -> FiniteSpace + NamedFiniteSpace : {rank : Number} -> SpaceName rank -> FiniteSpace public export -spaceRank : FiniteSpace -> ℕ +spaceRank : FiniteSpace -> Number spaceRank (NamedFiniteSpace {rank} _) = rank public export @@ -58,20 +57,20 @@ real128Space = NamedFiniteSpace Real128Name -- never performs such a conversion implicitly. public export -data RawExactCoordinates : ℕ -> Type where +data RawExactCoordinates : Number -> Type where UnsafeCoordinateNil : RawExactCoordinates Z UnsafeCoordinateCons : - {n : ℕ} -> + {n : Number} -> Integer -> RawExactCoordinates n -> RawExactCoordinates (S n) public export -unsafeZeroCoordinates : (n : ℕ) -> RawExactCoordinates n +unsafeZeroCoordinates : (n : Number) -> RawExactCoordinates n unsafeZeroCoordinates Z = UnsafeCoordinateNil unsafeZeroCoordinates (S n) = UnsafeCoordinateCons 0 (unsafeZeroCoordinates n) public export unsafeAddCoordinates : - {n : ℕ} -> + {n : Number} -> RawExactCoordinates n -> RawExactCoordinates n -> RawExactCoordinates n unsafeAddCoordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil unsafeAddCoordinates @@ -82,14 +81,14 @@ unsafeAddCoordinates (unsafeAddCoordinates leftRest rightRest) public export -unsafeNegateCoordinates : {n : ℕ} -> RawExactCoordinates n -> RawExactCoordinates n +unsafeNegateCoordinates : {n : Number} -> RawExactCoordinates n -> RawExactCoordinates n unsafeNegateCoordinates UnsafeCoordinateNil = UnsafeCoordinateNil unsafeNegateCoordinates (UnsafeCoordinateCons value rest) = UnsafeCoordinateCons (-value) (unsafeNegateCoordinates rest) public export unsafeSubtractCoordinates : - {n : ℕ} -> + {n : Number} -> RawExactCoordinates n -> RawExactCoordinates n -> RawExactCoordinates n unsafeSubtractCoordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil unsafeSubtractCoordinates @@ -101,7 +100,7 @@ unsafeSubtractCoordinates public export unsafeScaleCoordinates : - {n : ℕ} -> Integer -> RawExactCoordinates n -> RawExactCoordinates n + {n : Number} -> Integer -> RawExactCoordinates n -> RawExactCoordinates n unsafeScaleCoordinates scalar UnsafeCoordinateNil = UnsafeCoordinateNil unsafeScaleCoordinates scalar (UnsafeCoordinateCons value rest) = UnsafeCoordinateCons @@ -113,7 +112,7 @@ unsafeScaleCoordinates scalar (UnsafeCoordinateCons value rest) = -- the checked vector/covector API; `dot` is the metric-requiring operation. public export unsafePairCoordinates : - {n : ℕ} -> + {n : Number} -> RawExactCoordinates n -> RawExactCoordinates n -> Integer unsafePairCoordinates UnsafeCoordinateNil UnsafeCoordinateNil = 0 unsafePairCoordinates @@ -127,7 +126,7 @@ unsafePairCoordinates public export data ExactVectorSample : FiniteSpace -> Type where UnsafeVectorCoordinates : - {rank : ℕ} -> + {rank : Number} -> {name : SpaceName rank} -> RawExactCoordinates rank -> ExactVectorSample (NamedFiniteSpace name) @@ -135,7 +134,7 @@ data ExactVectorSample : FiniteSpace -> Type where public export data ExactCovectorSample : FiniteSpace -> Type where UnsafeCovectorCoordinates : - {rank : ℕ} -> + {rank : Number} -> {name : SpaceName rank} -> RawExactCoordinates rank -> ExactCovectorSample (NamedFiniteSpace name) diff --git a/_/examples/unified-higher-mathematics/NamedFacts.idric b/_/examples/unified-higher-mathematics/NamedFacts.idric index 615f7292f9..1236571c3d 100644 --- a/_/examples/unified-higher-mathematics/NamedFacts.idric +++ b/_/examples/unified-higher-mathematics/NamedFacts.idric @@ -2,7 +2,6 @@ module NamedFacts import TopologyFacts -%default total %unbound_implicits off -- A deliberately tiny boundary between ordinary type checking and named @@ -13,11 +12,11 @@ import TopologyFacts public export record FactProvenance where constructor MkFactProvenance - factNamespace : String - factName : String - factVersion : String + factNamespace : Text + factName : Text + factVersion : Text -- A declared code-source locator, not a checked citation. - factSource : String + factSource : Text public export data NamedFact : @@ -67,7 +66,7 @@ answerOrigin : {result : Type} -> FactAnswer result -> FactOrigin answerOrigin (FromNamedFact provenance _) = NamedFactLookup provenance public export -factExplanation : {result : Type} -> FactAnswer result -> String +factExplanation : {result : Type} -> FactAnswer result -> Text factExplanation (FromNamedFact provenance _) = "named fact " ++ factNamespace provenance diff --git a/_/examples/unified-higher-mathematics/PresheafRestriction.idric b/_/examples/unified-higher-mathematics/PresheafRestriction.idric index 5509c012a2..a78a94cb41 100644 --- a/_/examples/unified-higher-mathematics/PresheafRestriction.idric +++ b/_/examples/unified-higher-mathematics/PresheafRestriction.idric @@ -1,6 +1,5 @@ module PresheafRestriction -%default total %unbound_implicits off -- A finite restriction experiment, separate from the Euclidean geometry diff --git a/_/examples/unified-higher-mathematics/Tests.idric b/_/examples/unified-higher-mathematics/Tests.idric index ca82946298..6694c64afe 100644 --- a/_/examples/unified-higher-mathematics/Tests.idric +++ b/_/examples/unified-higher-mathematics/Tests.idric @@ -6,7 +6,6 @@ import TopologyFacts import PresheafRestriction import NamedFacts -%default total %unbound_implicits off -- These tests specify the reconciliation before its implementation. Rank @@ -161,7 +160,7 @@ metric_driven_index_raising_test = Refl -- state all 128 coordinates; semantic clients use the named constructors and -- checked contraction/metric operations above. -lastCoordinate : (n : ℕ) -> Integer -> RawExactCoordinates (S n) +lastCoordinate : (n : Number) -> Integer -> RawExactCoordinates (S n) lastCoordinate Z value = UnsafeCoordinateCons value UnsafeCoordinateNil lastCoordinate (S n) value = UnsafeCoordinateCons 0 (lastCoordinate n value) @@ -271,7 +270,7 @@ r128_four_quarter_turns_are_identity_test : = r128_sample r128_four_quarter_turns_are_identity_test = Refl -lastCoordinateValue : {n : ℕ} -> RawExactCoordinates (S n) -> Integer +lastCoordinateValue : {n : Number} -> RawExactCoordinates (S n) -> Integer lastCoordinateValue (UnsafeCoordinateCons value UnsafeCoordinateNil) = value lastCoordinateValue (UnsafeCoordinateCons _ rest@(UnsafeCoordinateCons _ _)) = lastCoordinateValue rest diff --git a/_/examples/unified-higher-mathematics/TopologyFacts.idric b/_/examples/unified-higher-mathematics/TopologyFacts.idric index d673ba2d28..cd200f1f43 100644 --- a/_/examples/unified-higher-mathematics/TopologyFacts.idric +++ b/_/examples/unified-higher-mathematics/TopologyFacts.idric @@ -3,7 +3,6 @@ module TopologyFacts import MathematicalSpaces import EuclideanGeometry -%default total %unbound_implicits off -- This module preserves the settled elementary topology facts from #45 while @@ -44,7 +43,7 @@ northPoleS2 = -- only nonzero ranks are in degrees 0 and n. This is a closed standard fact, -- not a general cohomology calculation. public export -sphereIntegralCohomologyRank : ℕ -> ℕ -> ℕ +sphereIntegralCohomologyRank : Number -> Number -> Number sphereIntegralCohomologyRank Z Z = 2 sphereIntegralCohomologyRank Z (S degree) = 0 sphereIntegralCohomologyRank (S dimension) Z = 1 @@ -60,13 +59,13 @@ flipParity Even = Odd flipParity Odd = Even public export -natParity : ℕ -> Parity +natParity : Number -> Parity natParity Z = Even natParity (S n) = flipParity (natParity n) -- chi(S^n) = 1 + (-1)^n. public export -sphereEulerCharacteristic : ℕ -> Integer +sphereEulerCharacteristic : Number -> Integer sphereEulerCharacteristic dimension = case natParity dimension of Even => 2 @@ -78,21 +77,21 @@ sphereEulerCharacteristic dimension = -- CP^n has complex dimension n and real dimension 2n. public export -cpRealDimension : ℕ -> ℕ +cpRealDimension : Number -> Number cpRealDimension n = n + n -- CP^n has the standard Hopf presentation S^(2n+1) / S^1. This returns the -- dimension of the sphere in that presentation; it does not implement quotient -- equality or construct projective space. public export -cpHopfSphereDimension : ℕ -> ℕ +cpHopfSphereDimension : Number -> Number cpHopfSphereDimension n = S (n + n) -- Additive integral cohomology ranks of CP^n are one in even degrees -- 0,2,...,2n and zero otherwise. The ring structure is deliberately outside -- this small fact table. public export -cpIntegralCohomologyRank : ℕ -> ℕ -> ℕ +cpIntegralCohomologyRank : Number -> Number -> Number cpIntegralCohomologyRank n Z = 1 cpIntegralCohomologyRank Z (S degree) = 0 cpIntegralCohomologyRank (S n) (S Z) = 0 @@ -100,11 +99,11 @@ cpIntegralCohomologyRank (S n) (S (S degree)) = cpIntegralCohomologyRank n degree public export -data HopfQuotientFact : ℕ -> Type where - CPnAsSphereByCircle : (n : ℕ) -> HopfQuotientFact n +data HopfQuotientFact : Number -> Type where + CPnAsSphereByCircle : (n : Number) -> HopfQuotientFact n public export -cpHopfQuotient : (n : ℕ) -> HopfQuotientFact n +cpHopfQuotient : (n : Number) -> HopfQuotientFact n cpHopfQuotient n = CPnAsSphereByCircle n -- -------------------------------------------------------------------------- @@ -135,24 +134,24 @@ jordanSeparation curve = ExactlyTwoComplementComponents curve public export complementComponentCount : - {curve : EmbeddedCircleInS2} -> JordanSeparation curve -> ℕ + {curve : EmbeddedCircleInS2} -> JordanSeparation curve -> Number complementComponentCount (ExactlyTwoComplementComponents curve) = 2 -- The one-point compactification of Euclidean R^n is S^n. The family is -- indexed explicitly so this fact cannot be mistaken for a generic -- compactification operation on arbitrary spaces. public export -data EuclideanCompactificationFact : ℕ -> Type where +data EuclideanCompactificationFact : Number -> Type where EuclideanPlusIsSphere : - (dimension : ℕ) -> EuclideanCompactificationFact dimension + (dimension : Number) -> EuclideanCompactificationFact dimension public export euclideanOnePointCompactification : - (dimension : ℕ) -> EuclideanCompactificationFact dimension + (dimension : Number) -> EuclideanCompactificationFact dimension euclideanOnePointCompactification dimension = EuclideanPlusIsSphere dimension public export compactifiedSphereDimension : - {n : ℕ} -> EuclideanCompactificationFact n -> ℕ + {n : Number} -> EuclideanCompactificationFact n -> Number compactifiedSphereDimension (EuclideanPlusIsSphere dimension) = dimension diff --git a/_/koans/01-values-types-and-holes/exercise/Main.idric b/_/koans/01-values-types-and-holes/exercise/Main.idric index 4b713c687b..23264768e8 100644 --- a/_/koans/01-values-types-and-holes/exercise/Main.idric +++ b/_/koans/01-values-types-and-holes/exercise/Main.idric @@ -1,12 +1,10 @@ module Main -%default total - -- Compile this file and read the types reported for these named holes. -answer : ℕ +answer : Number answer = ?natural_number -message : String +message : Text message = ?text_value main : IO () diff --git a/_/koans/01-values-types-and-holes/solution/Main.idric b/_/koans/01-values-types-and-holes/solution/Main.idric index 267deecadf..e0b78b492a 100644 --- a/_/koans/01-values-types-and-holes/solution/Main.idric +++ b/_/koans/01-values-types-and-holes/solution/Main.idric @@ -1,11 +1,9 @@ module Main -%default total - -answer : ℕ +answer : Number answer = 42 -message : String +message : Text message = "a value inhabits a type" main : IO () diff --git a/_/koans/02-functions-with-unicode-arrows/exercise/Main.idric b/_/koans/02-functions-with-unicode-arrows/exercise/Main.idric index d183485dd8..3a7d65e568 100644 --- a/_/koans/02-functions-with-unicode-arrows/exercise/Main.idric +++ b/_/koans/02-functions-with-unicode-arrows/exercise/Main.idric @@ -1,8 +1,6 @@ module Main -%default total - -increment : ℕ → ℕ +increment : Number → Number increment = \number ⇒ ?incremented twice : (a → a) → a → a diff --git a/_/koans/02-functions-with-unicode-arrows/solution/Main.idric b/_/koans/02-functions-with-unicode-arrows/solution/Main.idric index d6fe805ebb..4333db3c03 100644 --- a/_/koans/02-functions-with-unicode-arrows/solution/Main.idric +++ b/_/koans/02-functions-with-unicode-arrows/solution/Main.idric @@ -1,8 +1,6 @@ module Main -%default total - -increment : ℕ → ℕ +increment : Number → Number increment = \number ⇒ S number twice : (a → a) → a → a diff --git a/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric b/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric index c064df6789..5bfd478ee3 100644 --- a/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric @@ -2,13 +2,11 @@ module Main import Data.Vect -%default total - -- Idris 2 still exposes its length-indexed list as Data.Vect.Vect. -numbers : List ℕ +numbers : List Number numbers = [2, 4, 6] -exactly_three : Vect 3 ℕ +exactly_three : Vect 3 Number exactly_three = ?three_values prepend : a → Vect n a → Vect (S n) a diff --git a/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric b/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric index c3c24387b8..85b98d3248 100644 --- a/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric @@ -2,13 +2,11 @@ module Main import Data.Vect -%default total - -- Idris 2 still exposes its length-indexed list as Data.Vect.Vect. -numbers : List ℕ +numbers : List Number numbers = [2, 4, 6] -exactly_three : Vect 3 ℕ +exactly_three : Vect 3 Number exactly_three = [2, 4, 6] prepend : a → Vect n a → Vect (S n) a diff --git a/_/koans/04-equality-proofs/exercise/Main.idric b/_/koans/04-equality-proofs/exercise/Main.idric index ba39bc1bc2..1f435d86cf 100644 --- a/_/koans/04-equality-proofs/exercise/Main.idric +++ b/_/koans/04-equality-proofs/exercise/Main.idric @@ -1,11 +1,9 @@ module Main -%default total - self_equal : (value : a) → value = value self_equal value = ?identity_proof -two_plus_two : the ℕ (2 + 2) = 4 +two_plus_two : the Number (2 + 2) = 4 two_plus_two = ?arithmetic_proof main : IO () diff --git a/_/koans/04-equality-proofs/solution/Main.idric b/_/koans/04-equality-proofs/solution/Main.idric index e4eb157ffa..772e4cc735 100644 --- a/_/koans/04-equality-proofs/solution/Main.idric +++ b/_/koans/04-equality-proofs/solution/Main.idric @@ -1,11 +1,9 @@ module Main -%default total - self_equal : (value : a) → value = value self_equal value = Refl -two_plus_two : the ℕ (2 + 2) = 4 +two_plus_two : the Number (2 + 2) = 4 two_plus_two = Refl main : IO () diff --git a/_/koans/05-totality-and-coverage/exercise/Main.idric b/_/koans/05-totality-and-coverage/exercise/Main.idric index 2c73df8c75..ecefe74c6b 100644 --- a/_/koans/05-totality-and-coverage/exercise/Main.idric +++ b/_/koans/05-totality-and-coverage/exercise/Main.idric @@ -1,14 +1,12 @@ module Main -%default total - data Signal = Red | Amber | Green next : Signal → Signal next Red = Green next Green = Amber -signal_name : Signal → String +signal_name : Signal → Text signal_name Red = "red" signal_name Amber = "amber" signal_name Green = "green" diff --git a/_/koans/05-totality-and-coverage/solution/Main.idric b/_/koans/05-totality-and-coverage/solution/Main.idric index 7f7016f69b..699f533e59 100644 --- a/_/koans/05-totality-and-coverage/solution/Main.idric +++ b/_/koans/05-totality-and-coverage/solution/Main.idric @@ -1,7 +1,5 @@ module Main -%default total - data Signal = Red | Amber | Green next : Signal → Signal @@ -9,7 +7,7 @@ next Red = Green next Amber = Red next Green = Amber -signal_name : Signal → String +signal_name : Signal → Text signal_name Red = "red" signal_name Amber = "amber" signal_name Green = "green" diff --git a/_/koans/06-implicit-dependent-results/exercise/Main.idric b/_/koans/06-implicit-dependent-results/exercise/Main.idric index 83c1c5aceb..baf33de2e5 100644 --- a/_/koans/06-implicit-dependent-results/exercise/Main.idric +++ b/_/koans/06-implicit-dependent-results/exercise/Main.idric @@ -2,10 +2,8 @@ module Main import Data.Vect -%default total - -- n is inferred from values; the result type depends on that inferred value. -prepend : {n : ℕ} → a → Vect n a → Vect (S n) a +prepend : {n : Number} → a → Vect n a → Vect (S n) a prepend item items = ?dependent_result main : IO () diff --git a/_/koans/06-implicit-dependent-results/solution/Main.idric b/_/koans/06-implicit-dependent-results/solution/Main.idric index e5b1c848a1..a2cd47b03d 100644 --- a/_/koans/06-implicit-dependent-results/solution/Main.idric +++ b/_/koans/06-implicit-dependent-results/solution/Main.idric @@ -2,9 +2,7 @@ module Main import Data.Vect -%default total - -prepend : {n : ℕ} → a → Vect n a → Vect (S n) a +prepend : {n : Number} → a → Vect n a → Vect (S n) a prepend item items = item :: items main : IO () diff --git a/_/koans/07-erased-arguments/exercise/Main.idric b/_/koans/07-erased-arguments/exercise/Main.idric index e8ff56fd88..58010ab84c 100644 --- a/_/koans/07-erased-arguments/exercise/Main.idric +++ b/_/koans/07-erased-arguments/exercise/Main.idric @@ -1,9 +1,7 @@ module Main -%default total - -- A multiplicity-0 value may affect checking but cannot supply runtime data. -keep_runtime_value : (0 compile_time_number : ℕ) → ℕ → ℕ +keep_runtime_value : (0 compile_time_number : Number) → Number → Number keep_runtime_value compile_time_number runtime_number = ?runtime_number_only main : IO () diff --git a/_/koans/07-erased-arguments/solution/Main.idric b/_/koans/07-erased-arguments/solution/Main.idric index 9932fa6a54..dae35b8338 100644 --- a/_/koans/07-erased-arguments/solution/Main.idric +++ b/_/koans/07-erased-arguments/solution/Main.idric @@ -1,8 +1,6 @@ module Main -%default total - -keep_runtime_value : (0 compile_time_number : ℕ) → ℕ → ℕ +keep_runtime_value : (0 compile_time_number : Number) → Number → Number keep_runtime_value compile_time_number runtime_number = runtime_number main : IO () diff --git a/_/koans/08-linear-arguments/exercise/Main.idric b/_/koans/08-linear-arguments/exercise/Main.idric index 1fe0642958..2f96fe4523 100644 --- a/_/koans/08-linear-arguments/exercise/Main.idric +++ b/_/koans/08-linear-arguments/exercise/Main.idric @@ -1,7 +1,5 @@ module Main -%default total - apply_once : (1 value : a) → (consume : (1 item : a) → b) → b apply_once value consume = ?one_use diff --git a/_/koans/08-linear-arguments/solution/Main.idric b/_/koans/08-linear-arguments/solution/Main.idric index b7f753befb..a1dc05ce59 100644 --- a/_/koans/08-linear-arguments/solution/Main.idric +++ b/_/koans/08-linear-arguments/solution/Main.idric @@ -1,7 +1,5 @@ module Main -%default total - apply_once : (1 value : a) → (consume : (1 item : a) → b) → b apply_once value consume = consume value diff --git a/_/koans/09-storage-neutral-choices/exercise/Main.idric b/_/koans/09-storage-neutral-choices/exercise/Main.idric index dda7b6a1af..ff55fa9045 100644 --- a/_/koans/09-storage-neutral-choices/exercise/Main.idric +++ b/_/koans/09-storage-neutral-choices/exercise/Main.idric @@ -1,7 +1,5 @@ module Main -%default total - choice traffic_light one_of red amber @@ -10,7 +8,7 @@ choice traffic_light one_of starting_light : traffic_light starting_light = ?first_light -light_name : traffic_light → String +light_name : traffic_light → Text light_name red = "red" light_name amber = "amber" light_name green = "green" diff --git a/_/koans/09-storage-neutral-choices/solution/Main.idric b/_/koans/09-storage-neutral-choices/solution/Main.idric index 72dc2cf5eb..e97c080f1c 100644 --- a/_/koans/09-storage-neutral-choices/solution/Main.idric +++ b/_/koans/09-storage-neutral-choices/solution/Main.idric @@ -1,7 +1,5 @@ module Main -%default total - choice traffic_light one_of red amber @@ -10,7 +8,7 @@ choice traffic_light one_of starting_light : traffic_light starting_light = red -light_name : traffic_light → String +light_name : traffic_light → Text light_name red = "red" light_name amber = "amber" light_name green = "green" diff --git a/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric b/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric index 37c24545a2..24bff826f4 100644 --- a/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric +++ b/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric @@ -1,12 +1,10 @@ module Main -%default total - choice touch_beginning one_of - near_existing ℕ + near_existing Number empty_domain -describe : touch_beginning → String +describe : touch_beginning → Text describe (near_existing index) = "near point " ++ show index main : IO () diff --git a/_/koans/10-exhaustive-choice-patterns/solution/Main.idric b/_/koans/10-exhaustive-choice-patterns/solution/Main.idric index fe98651165..1292af67c3 100644 --- a/_/koans/10-exhaustive-choice-patterns/solution/Main.idric +++ b/_/koans/10-exhaustive-choice-patterns/solution/Main.idric @@ -1,12 +1,10 @@ module Main -%default total - choice touch_beginning one_of - near_existing ℕ + near_existing Number empty_domain -describe : touch_beginning → String +describe : touch_beginning → Text describe (near_existing index) = "near point " ++ show index describe empty_domain = "empty domain" diff --git a/_/koans/11-source-boundaries/exercise/Main.idric b/_/koans/11-source-boundaries/exercise/Main.idric index 21ff3d0d38..e10dc9702e 100644 --- a/_/koans/11-source-boundaries/exercise/Main.idric +++ b/_/koans/11-source-boundaries/exercise/Main.idric @@ -2,12 +2,10 @@ module Main import IdrisCompatibility -%default total - -increment : ℕ → ℕ +increment : Number → Number increment = \value ⇒ S value -boundary_value : ℕ +boundary_value : Number boundary_value = ?value_from_both_languages main : IO () diff --git a/_/koans/11-source-boundaries/solution/Main.idric b/_/koans/11-source-boundaries/solution/Main.idric index da3238dd8d..43d92ab305 100644 --- a/_/koans/11-source-boundaries/solution/Main.idric +++ b/_/koans/11-source-boundaries/solution/Main.idric @@ -2,12 +2,10 @@ module Main import IdrisCompatibility -%default total - -increment : ℕ → ℕ +increment : Number → Number increment = \value ⇒ S value -boundary_value : ℕ +boundary_value : Number boundary_value = increment compatibility_value main : IO () diff --git a/_/koans/12-wegert-model/exercise/Main.idric b/_/koans/12-wegert-model/exercise/Main.idric index 31ef285f41..f8eaa88e1c 100644 --- a/_/koans/12-wegert-model/exercise/Main.idric +++ b/_/koans/12-wegert-model/exercise/Main.idric @@ -2,33 +2,31 @@ module Main import Data.Vect -%default total - choice placement_kind one_of new_zero new_pole choice placed_point one_of - zero_at ℕ - pole_at ℕ + zero_at Number + pole_at Number -make_point : placement_kind → ℕ → placed_point +make_point : placement_kind → Number → placed_point make_point new_zero coordinate = ?zero_point make_point new_pole coordinate = ?pole_point place : (kind : placement_kind) → - (coordinate : ℕ) → + (coordinate : Number) → (points : Vect n placed_point) → (updated : Vect (S n) placed_point ** Vect.head updated = make_point kind coordinate) place kind coordinate points = ?updated_with_first_point -describe_point : placed_point → String +describe_point : placed_point → Text describe_point (zero_at coordinate) = "zero at " ++ show coordinate describe_point (pole_at coordinate) = "pole at " ++ show coordinate -first_description : placement_kind → ℕ → Vect n placed_point → String +first_description : placement_kind → Number → Vect n placed_point → Text first_description kind coordinate points = let (updated ** first_is_new) = place kind coordinate points in describe_point (Vect.head updated) diff --git a/_/koans/12-wegert-model/solution/Main.idric b/_/koans/12-wegert-model/solution/Main.idric index 348eb8599e..848f155397 100644 --- a/_/koans/12-wegert-model/solution/Main.idric +++ b/_/koans/12-wegert-model/solution/Main.idric @@ -2,34 +2,32 @@ module Main import Data.Vect -%default total - choice placement_kind one_of new_zero new_pole choice placed_point one_of - zero_at ℕ - pole_at ℕ + zero_at Number + pole_at Number -make_point : placement_kind → ℕ → placed_point +make_point : placement_kind → Number → placed_point make_point new_zero coordinate = zero_at coordinate make_point new_pole coordinate = pole_at coordinate place : (kind : placement_kind) → - (coordinate : ℕ) → + (coordinate : Number) → (points : Vect n placed_point) → (updated : Vect (S n) placed_point ** Vect.head updated = make_point kind coordinate) place kind coordinate points = (make_point kind coordinate :: points ** Refl) -describe_point : placed_point → String +describe_point : placed_point → Text describe_point (zero_at coordinate) = "zero at " ++ show coordinate describe_point (pole_at coordinate) = "pole at " ++ show coordinate -first_description : placement_kind → ℕ → Vect n placed_point → String +first_description : placement_kind → Number → Vect n placed_point → Text first_description kind coordinate points = let (updated ** first_is_new) = place kind coordinate points in describe_point (Vect.head updated) diff --git a/_/tests/idris2/basic/edric002/WegertSource.idric b/_/tests/idris2/basic/edric002/WegertSource.idric index 4dfaf63855..ccecbc165f 100644 --- a/_/tests/idris2/basic/edric002/WegertSource.idric +++ b/_/tests/idris2/basic/edric002/WegertSource.idric @@ -1,5 +1,5 @@ module WegertSource export -project_name : String +project_name : Text project_name = "Wegert" diff --git a/_/tests/idris2/basic/edric003/Main.idric b/_/tests/idris2/basic/edric003/Main.idric index 1bdb4f1e2e..1d41523de3 100644 --- a/_/tests/idris2/basic/edric003/Main.idric +++ b/_/tests/idris2/basic/edric003/Main.idric @@ -2,21 +2,21 @@ module Main import WegertTouch -describe_existing : existing_touch_target -> String +describe_existing : existing_touch_target -> Text describe_existing (fixed_value value) = "fixed_value " ++ show value describe_existing (zero value) = "zero " ++ show value describe_existing (pole value) = "pole " ++ show value -describe_beginning : touch_beginning -> String +describe_beginning : touch_beginning -> Text describe_beginning (near_existing target) = "near_existing (" ++ describe_existing target ++ ")" describe_beginning empty_domain = "empty_domain" -describe_placement : placement_kind -> String +describe_placement : placement_kind -> Text describe_placement new_zero = "new_zero" describe_placement new_pole = "new_pole" -chain_depth : recursive_chain -> ℕ +chain_depth : recursive_chain -> Number chain_depth chain_end = Z chain_depth (chain_link chain_end) = 1 chain_depth (chain_link (chain_link rest)) = 2 + chain_depth rest diff --git a/_/tests/idris2/basic/edric003/WegertTouch.idric b/_/tests/idris2/basic/edric003/WegertTouch.idric index 8e10b3692a..cddf741c65 100644 --- a/_/tests/idris2/basic/edric003/WegertTouch.idric +++ b/_/tests/idris2/basic/edric003/WegertTouch.idric @@ -2,9 +2,9 @@ module WegertTouch public export choice existing_touch_target one_of - fixed_value ℕ - zero ℕ - pole ℕ + fixed_value Number + zero Number + pole Number public export choice touch_beginning one_of diff --git a/_/tests/idris2/basic/edric005/Main.idric b/_/tests/idris2/basic/edric005/Main.idric index 0ca646cdb2..f84bf17f02 100644 --- a/_/tests/idris2/basic/edric005/Main.idric +++ b/_/tests/idris2/basic/edric005/Main.idric @@ -17,7 +17,7 @@ unicode_order = 1≤2 ascii_order : Bool ascii_order = 1 <= 2 -syntax_literal : String +syntax_literal : Text syntax_literal = "-> => → ⇒ ← ≤" main : IO () From 2729fb595175ca2597d62fa9a46788efbb9008cc Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 09:46:19 -0400 Subject: [PATCH 32/80] =?UTF-8?q?Use=20shared=20ai-ci=20Idri=C3=A7=20style?= =?UTF-8?q?=20gate?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/ci_idric_style.yml | 26 ++------------------------ 1 file changed, 2 insertions(+), 24 deletions(-) diff --git a/.github/workflows/ci_idric_style.yml b/.github/workflows/ci_idric_style.yml index d8e9963419..77cdbaa827 100644 --- a/.github/workflows/ci_idric_style.yml +++ b/.github/workflows/ci_idric_style.yml @@ -11,30 +11,8 @@ jobs: style: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 with: fetch-depth: 0 - name: Check newly added Idriç source - shell: sh - env: - EVENT_NAME: ${{ github.event_name }} - PR_BASE_SHA: ${{ github.event.pull_request.base.sha }} - PUSH_BEFORE_SHA: ${{ github.event.before }} - run: | - base="$PUSH_BEFORE_SHA" - - if [ "$EVENT_NAME" = "pull_request" ]; then - base="$PR_BASE_SHA" - fi - - case "$base" in - ""|0000000000000000000000000000000000000000) - base="$(git rev-parse HEAD^)" - ;; - esac - - if ! git cat-file -e "$base^{commit}" 2>/dev/null; then - base="$(git rev-parse HEAD^)" - fi - - sh _/style/check_added_source "$base" HEAD + uses: isomorphisms/ai-ci/idric-style@d76e865c3742c51308ddf211ee6f5b724f4104de From 1d07eed41d36ab8a0ecb160af3183da615e8bbfd Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 09:46:25 -0400 Subject: [PATCH 33/80] =?UTF-8?q?Remove=20duplicate=20local=20Idri=C3=A7?= =?UTF-8?q?=20style=20checker?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- _/style/check_added_source | 74 -------------------------------------- 1 file changed, 74 deletions(-) delete mode 100644 _/style/check_added_source diff --git a/_/style/check_added_source b/_/style/check_added_source deleted file mode 100644 index 979bef705e..0000000000 --- a/_/style/check_added_source +++ /dev/null @@ -1,74 +0,0 @@ -#!/bin/sh -set -eu - -if [ "$#" -lt 1 ] || [ "$#" -gt 2 ]; then - echo "usage: $0 BASE [HEAD]" >&2 - exit 2 -fi - -base=$1 -head=${2:-HEAD} - -# Check only lines added by this change. The repository still contains a large -# inherited Idris codebase; this gate prevents new Idriç-facing source from -# drifting back toward those defaults without demanding an unrelated rewrite. -git diff --unified=0 --no-color "$base" "$head" -- '*.idr' '*.idric' | -awk ' -function annotation(level, message) { - if (path == "") { - print level ": " message > "/dev/stderr" - return - } - - printf "::%s file=%s,line=%d::%s\n", level, path, line, message > "/dev/stderr" -} - -function source_code(added, p) { - # Remove ordinary Idris/Idriç line comments. This deliberately does not try - # to parse the language; the check is a small drift detector, not a compiler. - p = index(added, "--") - if (p > 0) - return substr(added, 1, p - 1) - return added -} - -/^\+\+\+ b\// { - path = substr($0, 7) - next -} - -/^@@ / { - if (match($0, /\+[0-9]+/)) - line = substr($0, RSTART + 1, RLENGTH - 1) + 0 - next -} - -/^\+/ && !/^\+\+\+/ { - added = substr($0, 2) - code = source_code(added) - - if (code ~ /(^|[^[:alnum:]_])Nat([^[:alnum:]_]|$)/) { - annotation("error", "Idriç source must not introduce Nat. Use Number for an ordinary number/count; if nonnegativity or a range is meaningful, use a semantic restricted type.") - errors++ - } - - if (code ~ /(^|[^[:alnum:]_])Vect([^[:alnum:]_]|$)/) { - annotation("error", "Idriç source must not introduce Vect. Use List when length is not part of the meaning; if length matters, use a semantic collection/restriction rather than generic Vect.") - errors++ - } - - if (code ~ /(^|[^[:alnum:]_])[a-z][[:alnum:]_]*[A-Z][[:alnum:]_]*([^[:alnum:]_]|$)/) - annotation("warning", "lowerCamelCase is an Idriç style canary. Do not merely rename the token: re-read STYLE.md and the surrounding design, then use snake_case if this identifier belongs in Idriç-facing code.") - - if (code ~ /->|<-/) - annotation("warning", "ASCII arrows are an Idriç style canary. Re-check the design rather than applying a blind replacement; Idriç-facing notation uses real arrows such as → and ←.") - - line++ - next -} - -END { - if (errors > 0) - exit 1 -} -' From 78b36dcf66305d4f4f126f474dd1479b1bd17cc8 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 09:47:03 -0400 Subject: [PATCH 34/80] =?UTF-8?q?Expand=20canonical=20Idri=C3=A7=20style?= =?UTF-8?q?=20guide?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- STYLE.md | 159 +++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 119 insertions(+), 40 deletions(-) diff --git a/STYLE.md b/STYLE.md index 11e14a347d..a221aa5aeb 100644 --- a/STYLE.md +++ b/STYLE.md @@ -1,61 +1,140 @@ # Idriç source style -This file records Idriç rules that have actually been decided. It is deliberately -incomplete. The language and its programming style are still being worked out -with a human in the loop. +This is the canonical style guide for new Idriç-facing source. It records rules +that have actually been decided; it is not a license to fill gaps with ordinary +Idris, Haskell, or generic functional-programming habits. -Valid Idris is not automatically good Idriç. Do not fill gaps in this document -by reverting to conventional Idris, Haskell, or generic functional-programming -style. +The canonical intent examples are: -## Established mechanical rules +- [`examples/intent/railway/`](examples/intent/railway/README.md) +- [`examples/intent/http_server/`](examples/intent/http_server/README.md) -### `Nat` is prohibited in new Idriç-facing source +Read them as examples of structure and vocabulary, not as a frozen grammar. -Use `Number` when the program means an ordinary number or count. +## Say what the program is doing first -If nonnegativity, sign, bounds, units, or another restriction are part of the -meaning, do not reach for `Nat` as an implementation-shaped substitute. Give -that meaning a semantic restricted type. +Top-level code should read like a short, purpose-ordered recipe. Put intent above +mechanism. A reader should be able to understand the job before descending into +parsing, buffers, FFI calls, syscalls, allocation, or another implementation +choice. -Do not mechanically replace every historical `Nat` in inherited Idris code. -This rule prevents new Idriç source from adding more of it. +Prefer meaningful domain phrases and semantic roles. For example: -### `Vect` is prohibited in new Idriç-facing source +```idric +connection ← accept connection from listener +request ← read request from connection +response ← answer request +write response to connection +``` -Use `List` when the length is not part of what the program means. +Prefer grammatical phrases with words such as `from`, `to`, `on`, `with`, +`using`, and `via` when they make roles clear. Avoid piles of positional +arguments whose meaning is recoverable only from a signature. -If a length or shape really is semantically important, preserve that fact with -a domain-specific collection or restriction. Do not use generic `Vect` merely -because Idris makes it available, and do not blindly replace `Vect` with `List` -when doing so would erase meaning. +Do not force a semantic phrase to mirror the filesystem. `read request from +connection` can have one meaning even if its implementation eventually lives +under `read/`, `request/`, `connection/`, or another sensible deep-dive path. -### Use `snake_case`, not lower camel case +## Names must carry meaning -A newly introduced lowerCamelCase identifier is a style canary. It often means -the surrounding code was written from Idris/Haskell habit rather than from the -Idriç design. +Use ordinary or domain vocabulary instead of inherited implementation jargon. +A name should tell the reader what a value or action means in this program. -The mechanical check warns rather than rewrites it. When the warning appears, -inspect the whole declaration and its vocabulary before deciding the correct -`snake_case` name. +Use `snake_case`, not lowerCamelCase, for ordinary identifiers. -### Use real arrows in Idriç-facing notation +Avoid names such as `ExternalInvocation`, `InvokeExternal`, abbreviations that +save little space, and generic numbered/positional names when a domain name is +available. -Use `→` and `←`, not ASCII `->` and `<-`, when writing Idriç-facing source. +Prefer semantic types at boundaries: port, duration, byte count, HTTP method, +destination, output pin, and similar roles are better than exposing a generic +machine representation. -An ASCII arrow is also a style canary. Do not treat the warning as a request for -blind character substitution; re-check the declaration for other inherited -Idris/Haskell defaults at the same time. +## Types should describe the domain -## Human corrections are part of the specification +Do not introduce `Nat` in new Idriç-facing source. Use `Number` for an ordinary +number or count. If nonnegativity, sign, bounds, units, or another restriction +matters, represent that semantic restriction explicitly. -There is not yet a blessed directory of canonical "good Idriç" examples. -Current work in Idriç, ICU, ish, Idric-Net, and related repositories is still -being corrected and refined. +Do not introduce generic `Vect` merely because Idris provides it. Use `List` +when length is not part of the meaning. If length or shape matters, preserve +that fact with a domain-specific collection or semantic restriction. -When the user corrects generated code, treat the correction as evidence about -the language style. Repeated corrections should become explicit rules or -mechanical checks when the rule is clear enough. +Do not leak raw representations such as `Bits8` into domain code when a named +alias or restricted semantic type would say what the bytes mean. -Do not declare an example canonical without explicit human approval. +Strong typing should clarify real boundaries and relationships, not turn the +source into type-theory ceremony. + +## Notation + +Use real Unicode notation in Idriç-facing source and documentation where the +language accepts it. + +- `→` for type/result direction +- `←` for effectful binding or receiving a result +- `⇒` for branch/result notation where applicable +- `=` for equality +- `≠` for inequality +- `≝` for “defined as” in intent notation and documentation +- `∘` for composition where it actually clarifies the expression +- Unicode `−` for mathematical minus rather than an ASCII hyphen when writing + mathematical notation + +Do not use ASCII `->` or `<-` as substitutes for Idriç-facing arrows. + +Use `$` when it materially removes nested parentheses and makes the expression +read in its natural order. Do not add punctuation merely to imitate another +functional language. + +## Expose mechanism by descent + +Use the filesystem as a deep-dive structure. Descriptive top-level files and +directories should expose purpose; deeper files can expose concrete algorithms, +foreign calls, and machine details. One concrete implementation per file is +fine when it makes alternatives inspectable. + +A directory may contain multiple implementations of the same high-level action. +Callers should import the implementation or small aggregation they actually +need rather than pulling in a broad library by default. + +Hide FFI declarations, primitives, host-language glue, raw syscalls, and similar +machinery below high-level wrappers. Explain why a primitive or foreign boundary +exists and what guarantee or constraint it carries. + +Keep build machinery under `_/` rather than mixing it with the domain hierarchy. +When implementation is split away from the high-level declaration, keep the +source relationship easy to follow from the top level. + +## Explain non-obvious constants + +Special numeric values, encoding boundaries, UTF-8 cutoffs, protocol numbers, +bit masks, and similar constants need semantic names or a short explanation. +The source should not require a reader to recognize an unexplained magic number. + +## Meaning errors are not style errors + +Do not hard-code readability preferences into the grammar merely to enforce a +house style. + +A compiler error is appropriate when meaning cannot be resolved, is ambiguous, +or is contradictory. For example, if no visible definition can give meaning to +`read request from connection`, report that unresolved semantic phrase and the +roles that were understood. + +Warnings are appropriate when the program has a meaning but naming, morphology, +metadata, or an expected relationship looks suspicious. + +Formatting and style checks should handle readability conventions such as +English-like phrasing, unnecessary abbreviations, positional argument piles, +and similar choices that do not make the program meaningless. + +## Human corrections remain authoritative + +These rules and the canonical intent examples are deliberately small. They do +not make every existing Idriç-family file canonical. Inherited Idris code in +this repository is especially not a style template for new Idriç work. + +When a human correction establishes or changes a convention, update this guide +or the canonical examples rather than repeatedly falling back to the old +habit. Do not silently broaden a local example into a language-wide rule. From 183c5b44f18ac32cc88dbc7de5629bb02611a5a1 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 09:47:13 -0400 Subject: [PATCH 35/80] =?UTF-8?q?Point=20agents=20at=20canonical=20Idri?= =?UTF-8?q?=C3=A7=20references?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- AGENTS.md | 47 +++++++++++++++-------------------------------- 1 file changed, 15 insertions(+), 32 deletions(-) diff --git a/AGENTS.md b/AGENTS.md index 2793f051dd..13f7b01099 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -1,39 +1,22 @@ # Idriç agent instructions -Read [STYLE.md](STYLE.md) before writing or reviewing Idriç-facing source. -Also read `_/AGENTS.md` for repository and branch rules. +Before writing or reviewing Idriç-facing source, read: -The repository contains a large inherited Idris codebase. Its existence is not -permission to reproduce Idris/Haskell style in new Idriç work. - -## Hard stops - -Do not introduce `Nat` or `Vect` in new Idriç-facing source. - -- For `Nat`, first ask what the value means. Use `Number` for an ordinary number - or count. If a restriction such as nonnegativity, a range, units, or another - domain property matters, represent that semantic restriction explicitly. -- For `Vect`, use `List` when length is not part of the meaning. If length or - shape matters, represent that semantic fact explicitly instead of defaulting - to generic `Vect`. +1. [`STYLE.md`](STYLE.md) +2. [`examples/intent/railway/`](examples/intent/railway/README.md) +3. [`examples/intent/http_server/`](examples/intent/http_server/README.md) +4. [`_/AGENTS.md`](_/AGENTS.md) for repository and branch rules -## Style canaries +`STYLE.md` is the canonical source-style guide. The two intent examples are the +canonical structural references. This file is operational guidance; do not copy +the full style guide into `AGENTS.md`. -Treat newly introduced lowerCamelCase identifiers or ASCII `->` / `<-` arrows -as evidence that you may have fallen back to Idris/Haskell defaults. - -Do not merely make the mechanical substitution and continue. Re-read -`STYLE.md`, re-read the surrounding declarations, and reconsider names, types, -structure, and vocabulary as a whole. If conversation history containing human -corrections is available, review it. Inspect relevant recent Idriç-family work -when useful, but do not assume any existing file is canonical unless the user -has said so. - -Use `snake_case` and real `→` / `←` arrows in Idriç-facing source. +The repository contains a large inherited Idris codebase. Its existence is not +permission to reproduce Idris/Haskell style in new Idriç work. -## Human-in-the-loop style development +Inspect the relevant surrounding Idriç work before inventing a new pattern, but +do not promote arbitrary existing files into style authorities. Human +corrections and the canonical guide/examples take precedence. -There is no finished corpus of approved "good Idriç" examples yet. The user's -corrections determine the style while it is being developed. When a correction -recurs and becomes unambiguous, prefer recording or enforcing it rather than -making the same default-style mistake again. +Work on a branch, keep changes narrow, and run the checks relevant to the code +you changed before proposing it for merge. From 31cd5e134ff65eec43e7660ff3db97e60a7b94b4 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 09:47:24 -0400 Subject: [PATCH 36/80] Add canonical railway intent example --- examples/intent/railway/README.md | 60 +++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) create mode 100644 examples/intent/railway/README.md diff --git a/examples/intent/railway/README.md b/examples/intent/railway/README.md new file mode 100644 index 0000000000..7df8810bf7 --- /dev/null +++ b/examples/intent/railway/README.md @@ -0,0 +1,60 @@ +# Railway intent example + +This example is a structural reference for Idriç: say what is being drawn first, +then descend into geometry and finally into pen/PostScript mechanics only when a +reader needs them. + +The notation here is intent-oriented. It is not a claim that every phrase is +already accepted by the current parser. + +## Top level: the thing the user asked for + +```idric +page ≝ postscript_page +output ≝ "railway.ps" + +draw railway_track on page +save page to output +``` + +A reader should not have to understand line caps, coordinate arithmetic, or +PostScript operators to discover that this program draws a railway track. + +## One level down: railway geometry + +```idric +draw railway_track on page ≝ + draw left_rail on page + draw right_rail on page + draw sleepers on page between left_rail and right_rail +``` + +`left_rail`, `right_rail`, and `sleepers` are domain objects. Their geometry can +be inspected separately without replacing the top-level purpose with a pile of +line operations. + +## Deeper: one rail as a visible line + +```idric +draw rail on page from start to finish ≝ + set line_width on page to rail_width + move pen on page to start + draw line on page to finish + stroke path on page +``` + +A concrete PostScript implementation may go deeper again and map those actions +to `setlinewidth`, `moveto`, `lineto`, and `stroke`. That machinery belongs below +the railway vocabulary, not in place of it. + +## What this example establishes + +- top-level source names the intended object before its mechanism; +- grammatical role words such as `on`, `from`, `to`, and `between` make argument + roles visible; +- a higher-level action can have several progressively more concrete + implementations; +- folder/file depth can mirror that descent without forcing the semantic phrase + to match one particular filesystem ownership convention; +- a visible result such as `railway.ps` gives the example a concrete acceptance + target. From bc3bd35d59611b910b9783490eb3235dc1c33689 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 09:47:36 -0400 Subject: [PATCH 37/80] Add canonical HTTP server intent example --- examples/intent/http_server/README.md | 80 +++++++++++++++++++++++++++ 1 file changed, 80 insertions(+) create mode 100644 examples/intent/http_server/README.md diff --git a/examples/intent/http_server/README.md b/examples/intent/http_server/README.md new file mode 100644 index 0000000000..8eaf660669 --- /dev/null +++ b/examples/intent/http_server/README.md @@ -0,0 +1,80 @@ +# HTTP server intent example + +This example is a structural reference for Idriç: the main path should describe +what the server does before exposing sockets, buffers, parser state, syscalls, or +foreign-library machinery. + +The notation here is intent-oriented. It is not a claim that every phrase is +already accepted by the current parser. + +## Top level: serve one request + +```idric +connection ← accept connection from listener +request ← read request from connection +response ← answer request +write response to connection +close connection +``` + +The nouns and prepositions expose semantic roles directly. `connection` is the +source of the request and the destination of the response; that information is +not hidden in argument position. + +## One level down: reading an HTTP request + +```idric +read request from connection ≝ + bytes ← read bytes from connection + text ← decode utf8 from bytes + request ← parse http_request from text + return request +``` + +If byte framing, streaming, or incremental parsing later matters, those details +can replace this implementation without changing the higher-level phrase used +by the server. + +## Boundary code stays below the domain action + +A concrete implementation may eventually descend through typed network wrappers +to a syscall, TLS library, or another foreign boundary. Keep that machinery +behind names that still say what the program is doing. Raw descriptors, buffer +layouts, status integers, and FFI declarations should not take over the +server's top-level vocabulary. + +## Missing meaning is a compiler problem, not a filesystem problem + +If the program can see no definition that gives meaning to: + +```idric +read request from connection +``` + +the useful failure is semantic: + +```text +undefined operation: +read request from connection + +understood roles: +action = read +thing = request +source = connection + +no visible definition matches that phrase +``` + +Do not require the programmer to decide first whether such an implementation +must live under `read/`, `request/`, or `connection/`. Semantic resolution and +filesystem organization are separate concerns. + +## What this example establishes + +- purpose-ordered top-level actions; +- explicit semantic roles instead of positional argument piles; +- intent above transport and parsing mechanism; +- typed boundaries between bytes, text, HTTP requests, and connections; +- unresolved, ambiguous, or contradictory meaning belongs in compiler errors; +- suspicious but still meaningful naming/metadata belongs in warnings or style + checks rather than hard grammar. From f28d7e26b89d3645b78fb1c7e6d7caaeb81ae4ba Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 09:49:03 -0400 Subject: [PATCH 38/80] =?UTF-8?q?Make=20Data.Text=20native=20Idri=C3=A7=20?= =?UTF-8?q?vocabulary?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Parser/Source.idr | 34 +++++++++++++++---- STYLE.md | 5 +-- _/EDRIC.md | 6 ++++ _/tests/idris2/basic/edric005/IdrisCompat.idr | 6 ++++ _/tests/idris2/basic/edric005/Main.idric | 6 ++++ _/tests/idris2/basic/edric005/expected | 2 ++ 6 files changed, 50 insertions(+), 9 deletions(-) diff --git a/Parser/Source.idr b/Parser/Source.idr index 78eab645c3..3d51eafe67 100644 --- a/Parser/Source.idr +++ b/Parser/Source.idr @@ -14,12 +14,32 @@ import System.File %default total -canonicalizeIdricToken : Token -> Token -canonicalizeIdricToken (Ident "choice") = Keyword "choice" -canonicalizeIdricToken (Ident "Number") = Ident "Nat" -canonicalizeIdricToken (Ident "Text") = Ident "String" -canonicalizeIdricToken (Ident "ℕ") = Ident "Nat" -canonicalizeIdricToken tok = tok +-- Namespace components are stored inside-out. This exact rewrite gives fresh +-- Idriç source a Data.Text boundary without renaming any unrelated module that +-- happens to contain a Text component. +replace_data_text_namespace_components : List String -> List String +replace_data_text_namespace_components ["Text", "Data"] = ["String", "Data"] +replace_data_text_namespace_components (part :: rest) + = part :: replace_data_text_namespace_components rest +replace_data_text_namespace_components [] = [] + +canonicalize_idric_namespace : Namespace -> Namespace +canonicalize_idric_namespace ns + = unsafeFoldNamespace $ + replace_data_text_namespace_components $ unsafeUnfoldNamespace ns + +canonicalize_idric_token : Token -> Token +canonicalize_idric_token (Ident "choice") = Keyword "choice" +canonicalize_idric_token (Ident "Number") = Ident "Nat" +canonicalize_idric_token (Ident "Text") = Ident "String" +canonicalize_idric_token (Ident "ℕ") = Ident "Nat" +canonicalize_idric_token (DotSepIdent ns "Text") + = if unsafeUnfoldNamespace ns == ["Data"] + then DotSepIdent ns "String" + else DotSepIdent (canonicalize_idric_namespace ns) "Text" +canonicalize_idric_token (DotSepIdent ns name) + = DotSepIdent (canonicalize_idric_namespace ns) name +canonicalize_idric_token tok = tok sourceSyntax : Maybe String -> SourceSyntax sourceSyntax (Just fname) = if isSuffixOf ".idric" fname @@ -30,7 +50,7 @@ sourceSyntax Nothing = IdrisSyntax sourceTokens : Maybe String -> List (WithBounds Token) -> List (WithBounds Token) sourceTokens (Just fname) toks = if isSuffixOf ".idric" fname - then map (map canonicalizeIdricToken) toks + then map (map canonicalize_idric_token) toks else toks sourceTokens Nothing toks = toks diff --git a/STYLE.md b/STYLE.md index 4bda74d2a5..38c3775398 100644 --- a/STYLE.md +++ b/STYLE.md @@ -25,8 +25,9 @@ able to re-export; it is not a ceremonial prefix for every definition. - Use `snake_case` for names under our control and prefer complete domain words to conventional Haskell abbreviations. - Use `Number`, not `Nat` or the older migration spelling `ℕ`, in new `.idric` - source. Use `Text`, not `String`, for decoded character text. Both lower to - inherited representations inside the bootstrap compiler. + source. Use `Text`, not `String`, for decoded character text, and import + `Data.Text` for inherited text operations. These spellings lower to inherited + representations inside the bootstrap compiler. - Use a semantic type instead of `Number`, `Text`, a raw integer, `Bits8`, or a flag when the value has narrower operations or invariants. - Use `List` for an ordinary sequence, `SizedList` or `ListOfLength` when length diff --git a/_/EDRIC.md b/_/EDRIC.md index 5178634fa8..d5e0c7e44c 100644 --- a/_/EDRIC.md +++ b/_/EDRIC.md @@ -31,6 +31,10 @@ source remains unchanged. The inherited names are implementation and compatibility spellings, not names for new Idriç APIs, examples, or teaching material. +Fresh `.idric` source imports `Data.Text` when it needs the inherited text +operations. The frontend lowers that exact module boundary to `Data.String`; +ordinary `.idr` module names remain unchanged. + `Number` and `Text` describe general language values. Code should still use a more specific semantic type—source location, byte count, path, protocol field, and so on—when operations or invariants differ. The older `ℕ` input spelling is @@ -218,6 +222,8 @@ A new thread working on Edric should: - Ordinary `.idr` use of `choice` and `one_of` as identifiers: preserved and regression-tested. - Idriç source spells nonnegative whole numbers `Number` and decoded character text `Text`; the frontend lowers both to inherited bootstrap representations. +- Idriç source spells the inherited text-operation module `Data.Text`; the + frontend lowers that exact module boundary to `Data.String`. - The older `ℕ` spelling remains a migration alias, not the current spelling. - Idriç source accepts `→`, `⇒`, `←`, and `≤` as compact aliases for `->`, `=>`, `<-`, and `<=`; the ASCII spellings remain accepted. - The aliases are filename-scoped to `.idric`; ordinary `.idr` Unicode identifiers remain unchanged. diff --git a/_/tests/idris2/basic/edric005/IdrisCompat.idr b/_/tests/idris2/basic/edric005/IdrisCompat.idr index b669ea4177..4db683c08d 100644 --- a/_/tests/idris2/basic/edric005/IdrisCompat.idr +++ b/_/tests/idris2/basic/edric005/IdrisCompat.idr @@ -1,8 +1,14 @@ module IdrisCompat +import Data.String + joined→⇒←≤name : Integer joined→⇒←≤name = 11 export idris_compat_value : Integer idris_compat_value = joined→⇒←≤name + +export +idris_string_module_words : List String +idris_string_module_words = Data.String.words "Idris keeps Data.String" diff --git a/_/tests/idris2/basic/edric005/Main.idric b/_/tests/idris2/basic/edric005/Main.idric index f84bf17f02..d7a9f77cce 100644 --- a/_/tests/idris2/basic/edric005/Main.idric +++ b/_/tests/idris2/basic/edric005/Main.idric @@ -1,5 +1,6 @@ module Main +import Data.Text import IdrisCompat unicode_function : Integer→Integer @@ -20,6 +21,9 @@ ascii_order = 1 <= 2 syntax_literal : Text syntax_literal = "-> => → ⇒ ← ≤" +text_words : Text → List Text +text_words text = Data.Text.words text + main : IO () main = do unicode_text←pure "unicode bind" @@ -32,4 +36,6 @@ main = do printLn unicode_order printLn ascii_order printLn idris_compat_value + printLn idris_string_module_words + printLn $ text_words "Data.Text is source vocabulary" putStrLn syntax_literal diff --git a/_/tests/idris2/basic/edric005/expected b/_/tests/idris2/basic/edric005/expected index b2f815bf30..69989638d0 100644 --- a/_/tests/idris2/basic/edric005/expected +++ b/_/tests/idris2/basic/edric005/expected @@ -6,4 +6,6 @@ ascii bind True True 11 +["Idris", "keeps", "Data.String"] +["Data.Text", "is", "source", "vocabulary"] -> => → ⇒ ← ≤ From 06b0769f7b7731b1fa0534ea5ef87bfab4bd2de2 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 11:34:46 -0400 Subject: [PATCH 39/80] =?UTF-8?q?Use=20native=20Idri=C3=A7=20notation=20in?= =?UTF-8?q?=20maintained=20examples?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../EuclideanGeometry.idric | 368 +++++++++--------- .../HIGH_DIMENSIONAL_VERIFICATION.md | 6 +- .../MathematicalSpaces.idric | 270 ++++++------- .../NamedFacts.idric | 86 ++-- .../PresheafRestriction.idric | 100 ++--- .../unified-higher-mathematics/README.md | 16 +- .../unified-higher-mathematics/Tests.idric | 304 +++++++-------- .../TopologyFacts.idric | 112 +++--- _/tests/idris2/basic/edric003/Main.idric | 10 +- 9 files changed, 636 insertions(+), 636 deletions(-) diff --git a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric index 3e7ee763dd..d2f412c48b 100644 --- a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric +++ b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric @@ -8,53 +8,53 @@ import MathematicalSpaces -- rank. This value records the additional choice of the standard coordinate -- Euclidean structure on one particular named space. public export -data EuclideanStructure : FiniteSpace -> Type where +data EuclideanStructure : FiniteSpace → Type where StandardCoordinate : - {rank : Number} -> - {name : SpaceName rank} -> + {rank : Number} → + {name : SpaceName rank} → EuclideanStructure (NamedFiniteSpace name) public export -planeEuclidean : EuclideanStructure planeSpace -planeEuclidean = StandardCoordinate +plane_euclidean : EuclideanStructure plane_space +plane_euclidean = StandardCoordinate public export -realThreeEuclidean : EuclideanStructure realThreeSpace -realThreeEuclidean = StandardCoordinate +real_three_euclidean : EuclideanStructure real_three_space +real_three_euclidean = StandardCoordinate public export -real128Euclidean : EuclideanStructure real128Space -real128Euclidean = StandardCoordinate +real128_euclidean : EuclideanStructure real128_space +real128_euclidean = StandardCoordinate -- The standard-coordinate metric is the explicit identification between a -- vector and its dual coordinate covector. No such operation is exported -- without a EuclideanStructure argument. public export -lowerIndex : - {space : FiniteSpace} -> - EuclideanStructure space -> ExactVectorSample space -> ExactCovectorSample space -lowerIndex StandardCoordinate (UnsafeVectorCoordinates coordinates) = +lower_index : + {space : FiniteSpace} → + EuclideanStructure space → ExactVectorSample space → ExactCovectorSample space +lower_index StandardCoordinate (UnsafeVectorCoordinates coordinates) = UnsafeCovectorCoordinates coordinates public export -raiseIndex : - {space : FiniteSpace} -> - EuclideanStructure space -> ExactCovectorSample space -> ExactVectorSample space -raiseIndex StandardCoordinate (UnsafeCovectorCoordinates coordinates) = +raise_index : + {space : FiniteSpace} → + EuclideanStructure space → ExactCovectorSample space → ExactVectorSample space +raise_index StandardCoordinate (UnsafeCovectorCoordinates coordinates) = UnsafeVectorCoordinates coordinates public export dot : - {space : FiniteSpace} -> - EuclideanStructure space -> - ExactVectorSample space -> ExactVectorSample space -> Integer -dot structure left right = contract (lowerIndex structure left) right + {space : FiniteSpace} → + EuclideanStructure space → + ExactVectorSample space → ExactVectorSample space → Integer +dot structure left right = contract (lower_index structure left) right public export -squaredNorm : - {space : FiniteSpace} -> - EuclideanStructure space -> ExactVectorSample space -> Integer -squaredNorm structure value = dot structure value value +squared_norm : + {space : FiniteSpace} → + EuclideanStructure space → ExactVectorSample space → Integer +squared_norm structure value = dot structure value value -- SquareRoot is deliberately symbolic. The exact integer radicand remains -- visible, and this small semantic layer makes no floating-point choice. @@ -63,44 +63,44 @@ data ExactSquareRoot = SquareRoot Integer public export norm : - {space : FiniteSpace} -> - EuclideanStructure space -> ExactVectorSample space -> ExactSquareRoot -norm structure value = SquareRoot (squaredNorm structure value) + {space : FiniteSpace} → + EuclideanStructure space → ExactVectorSample space → ExactSquareRoot +norm structure value = SquareRoot (squared_norm structure value) public export -squaredDistance : - {space : FiniteSpace} -> - EuclideanStructure space -> - ExactVectorSample space -> ExactVectorSample space -> Integer -squaredDistance structure left right = - squaredNorm structure (differenceVector left right) +squared_distance : + {space : FiniteSpace} → + EuclideanStructure space → + ExactVectorSample space → ExactVectorSample space → Integer +squared_distance structure left right = + squared_norm structure (difference_vector left right) public export distance : - {space : FiniteSpace} -> - EuclideanStructure space -> - ExactVectorSample space -> ExactVectorSample space -> ExactSquareRoot + {space : FiniteSpace} → + EuclideanStructure space → + ExactVectorSample space → ExactVectorSample space → ExactSquareRoot distance structure left right = - SquareRoot (squaredDistance structure left right) + SquareRoot (squared_distance structure left right) -- Variance changes are metric operations. Merely wrapping a value with an -- index-variance tag never changes an exact vector sample into an exact -- covector sample or conversely. public export -lowerIndexed : - {space : FiniteSpace} -> - EuclideanStructure space -> - IndexedValue Upper space -> IndexedValue Lower space -lowerIndexed structure (UpperIndex value) = - LowerIndex (lowerIndex structure value) +lower_indexed : + {space : FiniteSpace} → + EuclideanStructure space → + IndexedValue Upper space → IndexedValue Lower space +lower_indexed structure (UpperIndex value) = + LowerIndex (lower_index structure value) public export -raiseIndexed : - {space : FiniteSpace} -> - EuclideanStructure space -> - IndexedValue Lower space -> IndexedValue Upper space -raiseIndexed structure (LowerIndex value) = - UpperIndex (raiseIndex structure value) +raise_indexed : + {space : FiniteSpace} → + EuclideanStructure space → + IndexedValue Lower space → IndexedValue Upper space +raise_indexed structure (LowerIndex value) = + UpperIndex (raise_index structure value) -- -------------------------------------------------------------------------- -- Exact quaternion samples @@ -110,16 +110,16 @@ public export data Quaternion = Q Integer Integer Integer Integer public export -quaternionNegate : Quaternion -> Quaternion -quaternionNegate (Q a b c d) = Q (-a) (-b) (-c) (-d) +quaternion_negate : Quaternion → Quaternion +quaternion_negate (Q a b c d) = Q (-a) (-b) (-c) (-d) public export -quaternionConjugate : Quaternion -> Quaternion -quaternionConjugate (Q a b c d) = Q a (-b) (-c) (-d) +quaternion_conjugate : Quaternion → Quaternion +quaternion_conjugate (Q a b c d) = Q a (-b) (-c) (-d) public export -quaternionMultiply : Quaternion -> Quaternion -> Quaternion -quaternionMultiply (Q a b c d) (Q e f g h) = +quaternion_multiply : Quaternion → Quaternion → Quaternion +quaternion_multiply (Q a b c d) (Q e f g h) = Q (a * e - b * f - c * g - d * h) (a * f + b * e + c * h - d * g) @@ -127,48 +127,48 @@ quaternionMultiply (Q a b c d) (Q e f g h) = (a * h + b * g - c * f + d * e) public export -quaternionNormSquared : Quaternion -> Integer -quaternionNormSquared (Q a b c d) = +quaternion_norm_squared : Quaternion → Integer +quaternion_norm_squared (Q a b c d) = a * a + b * b + c * c + d * d public export -quatOne : Quaternion -quatOne = Q 1 0 0 0 +quaternion_one : Quaternion +quaternion_one = Q 1 0 0 0 public export -quatI : Quaternion -quatI = Q 0 1 0 0 +quaternion_i : Quaternion +quaternion_i = Q 0 1 0 0 public export -quatJ : Quaternion -quatJ = Q 0 0 1 0 +quaternion_j : Quaternion +quaternion_j = Q 0 0 1 0 public export -quatK : Quaternion -quatK = Q 0 0 0 1 +quaternion_k : Quaternion +quaternion_k = Q 0 0 0 1 public export data UnitQuaternion : Type where UnitQuaternionValue : - (value : Quaternion) -> - quaternionNormSquared value = 1 -> + (value : Quaternion) → + quaternion_norm_squared value = 1 → UnitQuaternion public export -unitQuatOne : UnitQuaternion -unitQuatOne = UnitQuaternionValue quatOne Refl +unit_quaternion_one : UnitQuaternion +unit_quaternion_one = UnitQuaternionValue quaternion_one Refl public export -unitQuatI : UnitQuaternion -unitQuatI = UnitQuaternionValue quatI Refl +unit_quaternion_i : UnitQuaternion +unit_quaternion_i = UnitQuaternionValue quaternion_i Refl public export -unitQuatJ : UnitQuaternion -unitQuatJ = UnitQuaternionValue quatJ Refl +unit_quaternion_j : UnitQuaternion +unit_quaternion_j = UnitQuaternionValue quaternion_j Refl public export -unitQuatK : UnitQuaternion -unitQuatK = UnitQuaternionValue quatK Refl +unit_quaternion_k : UnitQuaternion +unit_quaternion_k = UnitQuaternionValue quaternion_k Refl -- -------------------------------------------------------------------------- -- O(space), SO(space), and the exact #47 generators @@ -178,11 +178,11 @@ public export data Orientation = Preserving | Reversing public export -composeOrientation : Orientation -> Orientation -> Orientation -composeOrientation Preserving Preserving = Preserving -composeOrientation Preserving Reversing = Reversing -composeOrientation Reversing Preserving = Reversing -composeOrientation Reversing Reversing = Preserving +compose_orientation : Orientation → Orientation → Orientation +compose_orientation Preserving Preserving = Preserving +compose_orientation Preserving Reversing = Reversing +compose_orientation Reversing Preserving = Reversing +compose_orientation Reversing Reversing = Preserving -- The Euclidean value itself is an index. Thus an orthogonal transform is -- not transferable to another named rank-equal space or to another metric. @@ -193,90 +193,90 @@ composeOrientation Reversing Reversing = Preserving -- general metric-preservation theorem inside Idric. public export data OrthogonalTransform : - {space : FiniteSpace} -> - EuclideanStructure space -> Orientation -> Type where + {space : FiniteSpace} → + EuclideanStructure space → Orientation → Type where OrthogonalIdentity : - {space : FiniteSpace} -> - {structure : EuclideanStructure space} -> + {space : FiniteSpace} → + {structure : EuclideanStructure space} → OrthogonalTransform structure Preserving FirstAxisReflectionTransform : - {n : Number} -> - {name : SpaceName (S n)} -> + {n : Number} → + {name : SpaceName (S n)} → OrthogonalTransform {space = NamedFiniteSpace name} StandardCoordinate Reversing FirstPlaneQuarterTurnTransform : - {n : Number} -> - {name : SpaceName (S (S n))} -> + {n : Number} → + {name : SpaceName (S (S n))} → OrthogonalTransform {space = NamedFiniteSpace name} StandardCoordinate Preserving QuaternionRotationTransform : - UnitQuaternion -> - OrthogonalTransform realThreeEuclidean Preserving + UnitQuaternion → + OrthogonalTransform real_three_euclidean Preserving ComposeOrthogonal : - {space : FiniteSpace} -> - {structure : EuclideanStructure space} -> - {left : Orientation} -> - {right : Orientation} -> - OrthogonalTransform structure left -> - OrthogonalTransform structure right -> - OrthogonalTransform structure (composeOrientation left right) + {space : FiniteSpace} → + {structure : EuclideanStructure space} → + {left : Orientation} → + {right : Orientation} → + OrthogonalTransform structure left → + OrthogonalTransform structure right → + OrthogonalTransform structure (compose_orientation left right) public export data SpecialOrthogonal : - {space : FiniteSpace} -> EuclideanStructure space -> Type where + {space : FiniteSpace} → EuclideanStructure space → Type where InSO : - {space : FiniteSpace} -> - {structure : EuclideanStructure space} -> - OrthogonalTransform structure Preserving -> + {space : FiniteSpace} → + {structure : EuclideanStructure space} → + OrthogonalTransform structure Preserving → SpecialOrthogonal structure public export -firstAxisReflection : - {n : Number} -> - {name : SpaceName (S n)} -> - (structure : EuclideanStructure (NamedFiniteSpace name)) -> +first_axis_reflection : + {n : Number} → + {name : SpaceName (S n)} → + (structure : EuclideanStructure (NamedFiniteSpace name)) → OrthogonalTransform structure Reversing -firstAxisReflection StandardCoordinate = FirstAxisReflectionTransform +first_axis_reflection StandardCoordinate = FirstAxisReflectionTransform public export -firstPlaneQuarterTurn : - {n : Number} -> - {name : SpaceName (S (S n))} -> - (structure : EuclideanStructure (NamedFiniteSpace name)) -> +first_plane_quarter_turn : + {n : Number} → + {name : SpaceName (S (S n))} → + (structure : EuclideanStructure (NamedFiniteSpace name)) → SpecialOrthogonal structure -firstPlaneQuarterTurn StandardCoordinate = +first_plane_quarter_turn StandardCoordinate = InSO FirstPlaneQuarterTurnTransform public export -composeOrthogonal : - {space : FiniteSpace} -> - {structure : EuclideanStructure space} -> - {left : Orientation} -> - {right : Orientation} -> - OrthogonalTransform structure left -> - OrthogonalTransform structure right -> - OrthogonalTransform structure (composeOrientation left right) -composeOrthogonal = ComposeOrthogonal +compose_orthogonal : + {space : FiniteSpace} → + {structure : EuclideanStructure space} → + {left : Orientation} → + {right : Orientation} → + OrthogonalTransform structure left → + OrthogonalTransform structure right → + OrthogonalTransform structure (compose_orientation left right) +compose_orthogonal = ComposeOrthogonal public export -twoReflections : - {space : FiniteSpace} -> - {structure : EuclideanStructure space} -> - OrthogonalTransform structure Reversing -> - OrthogonalTransform structure Reversing -> +two_reflections : + {space : FiniteSpace} → + {structure : EuclideanStructure space} → + OrthogonalTransform structure Reversing → + OrthogonalTransform structure Reversing → SpecialOrthogonal structure -twoReflections left right = InSO (ComposeOrthogonal left right) +two_reflections left right = InSO (ComposeOrthogonal left right) public export -soTransform : - {space : FiniteSpace} -> - {structure : EuclideanStructure space} -> - SpecialOrthogonal structure -> OrthogonalTransform structure Preserving -soTransform (InSO transform) = transform +special_orthogonal_transform : + {space : FiniteSpace} → + {structure : EuclideanStructure space} → + SpecialOrthogonal structure → OrthogonalTransform structure Preserving +special_orthogonal_transform (InSO transform) = transform -- Exact integer-coordinate samples are a test representation inside the named -- real coordinate spaces. Every closed O/SO term has one evaluator on those @@ -284,8 +284,8 @@ soTransform (InSO transform) = transform -- disconnected marker values. public export %inline -vectorAsPureQuaternion : ExactVectorSample realThreeSpace -> Quaternion -vectorAsPureQuaternion +vector_as_pure_quaternion : ExactVectorSample real_three_space → Quaternion +vector_as_pure_quaternion (UnsafeVectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second @@ -293,85 +293,85 @@ vectorAsPureQuaternion Q 0 first second third public export %inline -vectorPart : Quaternion -> ExactVectorSample realThreeSpace -vectorPart (Q _ first second third) = threeVector first second third +vector_part : Quaternion → ExactVectorSample real_three_space +vector_part (Q _ first second third) = three_vector first second third public export %inline -rotateByUnitQuaternion : - UnitQuaternion -> - ExactVectorSample realThreeSpace -> ExactVectorSample realThreeSpace -rotateByUnitQuaternion (UnitQuaternionValue value _) vector = - vectorPart - (quaternionMultiply - (quaternionMultiply value (vectorAsPureQuaternion vector)) - (quaternionConjugate value)) - -public export -applyOrthogonalExact : - {space : FiniteSpace} -> - {structure : EuclideanStructure space} -> - {orientation : Orientation} -> - OrthogonalTransform structure orientation -> - ExactVectorSample space -> +rotate_by_unit_quaternion : + UnitQuaternion → + ExactVectorSample real_three_space → ExactVectorSample real_three_space +rotate_by_unit_quaternion (UnitQuaternionValue value _) vector = + vector_part + (quaternion_multiply + (quaternion_multiply value (vector_as_pure_quaternion vector)) + (quaternion_conjugate value)) + +public export +apply_orthogonal_exact : + {space : FiniteSpace} → + {structure : EuclideanStructure space} → + {orientation : Orientation} → + OrthogonalTransform structure orientation → + ExactVectorSample space → ExactVectorSample space -applyOrthogonalExact OrthogonalIdentity vector = vector -applyOrthogonalExact +apply_orthogonal_exact OrthogonalIdentity vector = vector +apply_orthogonal_exact FirstAxisReflectionTransform (UnsafeVectorCoordinates (UnsafeCoordinateCons first rest)) = UnsafeVectorCoordinates (UnsafeCoordinateCons (-first) rest) -applyOrthogonalExact +apply_orthogonal_exact FirstPlaneQuarterTurnTransform (UnsafeVectorCoordinates UnsafeCoordinateNil) impossible -applyOrthogonalExact +apply_orthogonal_exact FirstPlaneQuarterTurnTransform (UnsafeVectorCoordinates (UnsafeCoordinateCons _ UnsafeCoordinateNil)) impossible -applyOrthogonalExact +apply_orthogonal_exact FirstPlaneQuarterTurnTransform (UnsafeVectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second rest))) = UnsafeVectorCoordinates (UnsafeCoordinateCons (-second) (UnsafeCoordinateCons first rest)) -applyOrthogonalExact +apply_orthogonal_exact (QuaternionRotationTransform quaternion) vector = - rotateByUnitQuaternion quaternion vector + rotate_by_unit_quaternion quaternion vector -- ComposeOrthogonal left right denotes conventional function composition: -- apply right first, then left. -applyOrthogonalExact (ComposeOrthogonal left right) vector = - applyOrthogonalExact left (applyOrthogonalExact right vector) +apply_orthogonal_exact (ComposeOrthogonal left right) vector = + apply_orthogonal_exact left (apply_orthogonal_exact right vector) public export -applySpecialOrthogonalExact : - {space : FiniteSpace} -> - {structure : EuclideanStructure space} -> - SpecialOrthogonal structure -> - ExactVectorSample space -> +apply_special_orthogonal_exact : + {space : FiniteSpace} → + {structure : EuclideanStructure space} → + SpecialOrthogonal structure → + ExactVectorSample space → ExactVectorSample space -applySpecialOrthogonalExact (InSO transform) vector = - applyOrthogonalExact transform vector +apply_special_orthogonal_exact (InSO transform) vector = + apply_orthogonal_exact transform vector -- Named generator wrappers remain for the #47 API, but now delegate through -- the connected OrthogonalTransform evaluator. public export -applyFirstAxisReflection : - {n : Number} -> - {name : SpaceName (S n)} -> - (structure : EuclideanStructure (NamedFiniteSpace name)) -> - ExactVectorSample (NamedFiniteSpace name) -> +apply_first_axis_reflection : + {n : Number} → + {name : SpaceName (S n)} → + (structure : EuclideanStructure (NamedFiniteSpace name)) → + ExactVectorSample (NamedFiniteSpace name) → ExactVectorSample (NamedFiniteSpace name) -applyFirstAxisReflection structure = - applyOrthogonalExact (firstAxisReflection structure) +apply_first_axis_reflection structure = + apply_orthogonal_exact (first_axis_reflection structure) public export -applyFirstPlaneQuarterTurn : - {n : Number} -> - {name : SpaceName (S (S n))} -> - (structure : EuclideanStructure (NamedFiniteSpace name)) -> - ExactVectorSample (NamedFiniteSpace name) -> +apply_first_plane_quarter_turn : + {n : Number} → + {name : SpaceName (S (S n))} → + (structure : EuclideanStructure (NamedFiniteSpace name)) → + ExactVectorSample (NamedFiniteSpace name) → ExactVectorSample (NamedFiniteSpace name) -applyFirstPlaneQuarterTurn structure = - applySpecialOrthogonalExact (firstPlaneQuarterTurn structure) +apply_first_plane_quarter_turn structure = + apply_special_orthogonal_exact (first_plane_quarter_turn structure) public export -quaternionRotation : UnitQuaternion -> SpecialOrthogonal realThreeEuclidean -quaternionRotation value = InSO (QuaternionRotationTransform value) +quaternion_rotation : UnitQuaternion → SpecialOrthogonal real_three_euclidean +quaternion_rotation value = InSO (QuaternionRotationTransform value) diff --git a/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md b/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md index 13ddbb533d..93c5cdfd8c 100644 --- a/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md +++ b/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md @@ -31,7 +31,7 @@ y = (5, -2, 7, 0, ..., 0, 11). ``` Let `H` negate the first coordinate and let `G` make the first-plane -quarter-turn `(a, b) -> (-b, a)`. The exact expected images are +quarter-turn `(a, b) → (-b, a)`. The exact expected images are ```text H x = (-3, 4, 12, 0, ..., 0, 9) @@ -65,7 +65,7 @@ Mathematically, `det(H) = -1` and `det(G) = 1`. The Idric layer does not calculate arbitrary determinants. It records the corresponding orientation in closed transform constructors: `H` is `Reversing`, while `G` is `Preserving` and is exposed through `SpecialOrthogonal`. The same closed -syntax is interpreted by `applyOrthogonalExact`, removing the former API +syntax is interpreted by `apply_orthogonal_exact`, removing the former API disconnect between marker terms and separately selected evaluators. This is not a compiler-derived determinant or general orthogonality proof; the exact oracles and independent signed-permutation check cover these closed maps. @@ -92,7 +92,7 @@ squared norms, dot products, involution, fourth-power identity, and the preserved 128th coordinate by compiler normalization. Orientation is represented in the closed transform type: `H` is `Reversing`, `G` is in `SpecialOrthogonal`, and composition of two reflections -has a `SpecialOrthogonal real128Euclidean` result. +has a `SpecialOrthogonal real128_euclidean` result. These tests preserve #47's exact high-dimensional behavior. A Markdown calculation, successful parsing alone, or an external numerical result does diff --git a/_/examples/unified-higher-mathematics/MathematicalSpaces.idric b/_/examples/unified-higher-mathematics/MathematicalSpaces.idric index ad02a976db..c885845fce 100644 --- a/_/examples/unified-higher-mathematics/MathematicalSpaces.idric +++ b/_/examples/unified-higher-mathematics/MathematicalSpaces.idric @@ -8,7 +8,7 @@ module MathematicalSpaces -- Rank equality alone is still not space equality. public export -data SpaceName : Number -> Type where +data SpaceName : Number → Type where PlaneName : SpaceName 2 ImagePlaneName : SpaceName 2 RealThreeName : SpaceName 3 @@ -16,31 +16,31 @@ data SpaceName : Number -> Type where public export data FiniteSpace : Type where - NamedFiniteSpace : {rank : Number} -> SpaceName rank -> FiniteSpace + NamedFiniteSpace : {rank : Number} → SpaceName rank → FiniteSpace public export -spaceRank : FiniteSpace -> Number -spaceRank (NamedFiniteSpace {rank} _) = rank +space_rank : FiniteSpace → Number +space_rank (NamedFiniteSpace {rank} _) = rank public export -spaceName : (space : FiniteSpace) -> SpaceName (spaceRank space) -spaceName (NamedFiniteSpace name) = name +space_name : (space : FiniteSpace) → SpaceName (space_rank space) +space_name (NamedFiniteSpace name) = name public export -planeSpace : FiniteSpace -planeSpace = NamedFiniteSpace PlaneName +plane_space : FiniteSpace +plane_space = NamedFiniteSpace PlaneName public export -imagePlaneSpace : FiniteSpace -imagePlaneSpace = NamedFiniteSpace ImagePlaneName +image_plane_space : FiniteSpace +image_plane_space = NamedFiniteSpace ImagePlaneName public export -realThreeSpace : FiniteSpace -realThreeSpace = NamedFiniteSpace RealThreeName +real_three_space : FiniteSpace +real_three_space = NamedFiniteSpace RealThreeName public export -real128Space : FiniteSpace -real128Space = NamedFiniteSpace Real128Name +real128_space : FiniteSpace +real128_space = NamedFiniteSpace Real128Name -- Integer coordinates are exact executable samples of the named real -- coordinate spaces. ExactVectorSample and ExactCovectorSample below @@ -57,163 +57,163 @@ real128Space = NamedFiniteSpace Real128Name -- never performs such a conversion implicitly. public export -data RawExactCoordinates : Number -> Type where +data RawExactCoordinates : Number → Type where UnsafeCoordinateNil : RawExactCoordinates Z UnsafeCoordinateCons : - {n : Number} -> - Integer -> RawExactCoordinates n -> RawExactCoordinates (S n) + {n : Number} → + Integer → RawExactCoordinates n → RawExactCoordinates (S n) public export -unsafeZeroCoordinates : (n : Number) -> RawExactCoordinates n -unsafeZeroCoordinates Z = UnsafeCoordinateNil -unsafeZeroCoordinates (S n) = UnsafeCoordinateCons 0 (unsafeZeroCoordinates n) +unsafe_zero_coordinates : (n : Number) → RawExactCoordinates n +unsafe_zero_coordinates Z = UnsafeCoordinateNil +unsafe_zero_coordinates (S n) = UnsafeCoordinateCons 0 (unsafe_zero_coordinates n) public export -unsafeAddCoordinates : - {n : Number} -> - RawExactCoordinates n -> RawExactCoordinates n -> RawExactCoordinates n -unsafeAddCoordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil -unsafeAddCoordinates - (UnsafeCoordinateCons left leftRest) - (UnsafeCoordinateCons right rightRest) = +unsafe_add_coordinates : + {n : Number} → + RawExactCoordinates n → RawExactCoordinates n → RawExactCoordinates n +unsafe_add_coordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil +unsafe_add_coordinates + (UnsafeCoordinateCons left left_rest) + (UnsafeCoordinateCons right right_rest) = UnsafeCoordinateCons (left + right) - (unsafeAddCoordinates leftRest rightRest) + (unsafe_add_coordinates left_rest right_rest) public export -unsafeNegateCoordinates : {n : Number} -> RawExactCoordinates n -> RawExactCoordinates n -unsafeNegateCoordinates UnsafeCoordinateNil = UnsafeCoordinateNil -unsafeNegateCoordinates (UnsafeCoordinateCons value rest) = - UnsafeCoordinateCons (-value) (unsafeNegateCoordinates rest) +unsafe_negate_coordinates : {n : Number} → RawExactCoordinates n → RawExactCoordinates n +unsafe_negate_coordinates UnsafeCoordinateNil = UnsafeCoordinateNil +unsafe_negate_coordinates (UnsafeCoordinateCons value rest) = + UnsafeCoordinateCons (-value) (unsafe_negate_coordinates rest) public export -unsafeSubtractCoordinates : - {n : Number} -> - RawExactCoordinates n -> RawExactCoordinates n -> RawExactCoordinates n -unsafeSubtractCoordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil -unsafeSubtractCoordinates - (UnsafeCoordinateCons left leftRest) - (UnsafeCoordinateCons right rightRest) = +unsafe_subtract_coordinates : + {n : Number} → + RawExactCoordinates n → RawExactCoordinates n → RawExactCoordinates n +unsafe_subtract_coordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil +unsafe_subtract_coordinates + (UnsafeCoordinateCons left left_rest) + (UnsafeCoordinateCons right right_rest) = UnsafeCoordinateCons (left - right) - (unsafeSubtractCoordinates leftRest rightRest) + (unsafe_subtract_coordinates left_rest right_rest) public export -unsafeScaleCoordinates : - {n : Number} -> Integer -> RawExactCoordinates n -> RawExactCoordinates n -unsafeScaleCoordinates scalar UnsafeCoordinateNil = UnsafeCoordinateNil -unsafeScaleCoordinates scalar (UnsafeCoordinateCons value rest) = +unsafe_scale_coordinates : + {n : Number} → Integer → RawExactCoordinates n → RawExactCoordinates n +unsafe_scale_coordinates scalar UnsafeCoordinateNil = UnsafeCoordinateNil +unsafe_scale_coordinates scalar (UnsafeCoordinateCons value rest) = UnsafeCoordinateCons (scalar * value) - (unsafeScaleCoordinates scalar rest) + (unsafe_scale_coordinates scalar rest) -- This raw pairing is the implementation escape hatch used by safe covector -- evaluation. Calling it on two extracted vector samples explicitly leaves -- the checked vector/covector API; `dot` is the metric-requiring operation. public export -unsafePairCoordinates : - {n : Number} -> - RawExactCoordinates n -> RawExactCoordinates n -> Integer -unsafePairCoordinates UnsafeCoordinateNil UnsafeCoordinateNil = 0 -unsafePairCoordinates - (UnsafeCoordinateCons left leftRest) - (UnsafeCoordinateCons right rightRest) = - left * right + unsafePairCoordinates leftRest rightRest +unsafe_pair_coordinates : + {n : Number} → + RawExactCoordinates n → RawExactCoordinates n → Integer +unsafe_pair_coordinates UnsafeCoordinateNil UnsafeCoordinateNil = 0 +unsafe_pair_coordinates + (UnsafeCoordinateCons left left_rest) + (UnsafeCoordinateCons right right_rest) = + left * right + unsafe_pair_coordinates left_rest right_rest -- Exact vector and covector samples are intentionally different indexed -- datatypes. Their shared space index enforces both nominal identity and rank. public export -data ExactVectorSample : FiniteSpace -> Type where +data ExactVectorSample : FiniteSpace → Type where UnsafeVectorCoordinates : - {rank : Number} -> - {name : SpaceName rank} -> - RawExactCoordinates rank -> + {rank : Number} → + {name : SpaceName rank} → + RawExactCoordinates rank → ExactVectorSample (NamedFiniteSpace name) public export -data ExactCovectorSample : FiniteSpace -> Type where +data ExactCovectorSample : FiniteSpace → Type where UnsafeCovectorCoordinates : - {rank : Number} -> - {name : SpaceName rank} -> - RawExactCoordinates rank -> + {rank : Number} → + {name : SpaceName rank} → + RawExactCoordinates rank → ExactCovectorSample (NamedFiniteSpace name) public export -unsafeCoordinatesOfVector : - {space : FiniteSpace} -> - ExactVectorSample space -> - RawExactCoordinates (spaceRank space) -unsafeCoordinatesOfVector (UnsafeVectorCoordinates coordinates) = coordinates +unsafe_coordinates_of_vector : + {space : FiniteSpace} → + ExactVectorSample space → + RawExactCoordinates (space_rank space) +unsafe_coordinates_of_vector (UnsafeVectorCoordinates coordinates) = coordinates public export -unsafeCoordinatesOfCovector : - {space : FiniteSpace} -> - ExactCovectorSample space -> - RawExactCoordinates (spaceRank space) -unsafeCoordinatesOfCovector (UnsafeCovectorCoordinates coordinates) = coordinates +unsafe_coordinates_of_covector : + {space : FiniteSpace} → + ExactCovectorSample space → + RawExactCoordinates (space_rank space) +unsafe_coordinates_of_covector (UnsafeCovectorCoordinates coordinates) = coordinates public export -addVector : - {space : FiniteSpace} -> - ExactVectorSample space -> - ExactVectorSample space -> +add_vector : + {space : FiniteSpace} → + ExactVectorSample space → + ExactVectorSample space → ExactVectorSample space -addVector +add_vector (UnsafeVectorCoordinates left) (UnsafeVectorCoordinates right) = - UnsafeVectorCoordinates (unsafeAddCoordinates left right) + UnsafeVectorCoordinates (unsafe_add_coordinates left right) public export -negateVector : - {space : FiniteSpace} -> - ExactVectorSample space -> +negate_vector : + {space : FiniteSpace} → + ExactVectorSample space → ExactVectorSample space -negateVector (UnsafeVectorCoordinates coordinates) = - UnsafeVectorCoordinates (unsafeNegateCoordinates coordinates) +negate_vector (UnsafeVectorCoordinates coordinates) = + UnsafeVectorCoordinates (unsafe_negate_coordinates coordinates) public export -differenceVector : - {space : FiniteSpace} -> - ExactVectorSample space -> - ExactVectorSample space -> +difference_vector : + {space : FiniteSpace} → + ExactVectorSample space → + ExactVectorSample space → ExactVectorSample space -differenceVector +difference_vector (UnsafeVectorCoordinates left) (UnsafeVectorCoordinates right) = - UnsafeVectorCoordinates (unsafeSubtractCoordinates left right) + UnsafeVectorCoordinates (unsafe_subtract_coordinates left right) public export -scaleVector : - {space : FiniteSpace} -> - Integer -> ExactVectorSample space -> ExactVectorSample space -scaleVector scalar (UnsafeVectorCoordinates coordinates) = - UnsafeVectorCoordinates (unsafeScaleCoordinates scalar coordinates) +scale_vector : + {space : FiniteSpace} → + Integer → ExactVectorSample space → ExactVectorSample space +scale_vector scalar (UnsafeVectorCoordinates coordinates) = + UnsafeVectorCoordinates (unsafe_scale_coordinates scalar coordinates) public export -addCovector : - {space : FiniteSpace} -> - ExactCovectorSample space -> - ExactCovectorSample space -> +add_covector : + {space : FiniteSpace} → + ExactCovectorSample space → + ExactCovectorSample space → ExactCovectorSample space -addCovector +add_covector (UnsafeCovectorCoordinates left) (UnsafeCovectorCoordinates right) = - UnsafeCovectorCoordinates (unsafeAddCoordinates left right) + UnsafeCovectorCoordinates (unsafe_add_coordinates left right) public export -negateCovector : - {space : FiniteSpace} -> - ExactCovectorSample space -> ExactCovectorSample space -negateCovector (UnsafeCovectorCoordinates coordinates) = - UnsafeCovectorCoordinates (unsafeNegateCoordinates coordinates) +negate_covector : + {space : FiniteSpace} → + ExactCovectorSample space → ExactCovectorSample space +negate_covector (UnsafeCovectorCoordinates coordinates) = + UnsafeCovectorCoordinates (unsafe_negate_coordinates coordinates) public export -scaleCovector : - {space : FiniteSpace} -> - Integer -> ExactCovectorSample space -> ExactCovectorSample space -scaleCovector scalar (UnsafeCovectorCoordinates coordinates) = - UnsafeCovectorCoordinates (unsafeScaleCoordinates scalar coordinates) +scale_covector : + {space : FiniteSpace} → + Integer → ExactCovectorSample space → ExactCovectorSample space +scale_covector scalar (UnsafeCovectorCoordinates coordinates) = + UnsafeCovectorCoordinates (unsafe_scale_coordinates scalar coordinates) -- Evaluation is the canonical vector/covector contraction. There is no safe -- exact-vector-sample to exact-covector-sample conversion in this module and @@ -222,50 +222,50 @@ scaleCovector scalar (UnsafeCovectorCoordinates coordinates) = -- inferred mathematical operation. public export contract : - {space : FiniteSpace} -> - ExactCovectorSample space -> ExactVectorSample space -> Integer + {space : FiniteSpace} → + ExactCovectorSample space → ExactVectorSample space → Integer contract - (UnsafeCovectorCoordinates covectorCoordinates) - (UnsafeVectorCoordinates vectorCoordinates) = - unsafePairCoordinates covectorCoordinates vectorCoordinates + (UnsafeCovectorCoordinates covector_coordinates) + (UnsafeVectorCoordinates vector_coordinates) = + unsafe_pair_coordinates covector_coordinates vector_coordinates -- Small named fixtures used by the focused compiler tests. public export -planeVector : Integer -> Integer -> ExactVectorSample planeSpace -planeVector first second = +plane_vector : Integer → Integer → ExactVectorSample plane_space +plane_vector first second = UnsafeVectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -planeCovector : Integer -> Integer -> ExactCovectorSample planeSpace -planeCovector first second = +plane_covector : Integer → Integer → ExactCovectorSample plane_space +plane_covector first second = UnsafeCovectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -imagePlaneVector : Integer -> Integer -> ExactVectorSample imagePlaneSpace -imagePlaneVector first second = +image_plane_vector : Integer → Integer → ExactVectorSample image_plane_space +image_plane_vector first second = UnsafeVectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -imagePlaneCovector : Integer -> Integer -> ExactCovectorSample imagePlaneSpace -imagePlaneCovector first second = +image_plane_covector : Integer → Integer → ExactCovectorSample image_plane_space +image_plane_covector first second = UnsafeCovectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -threeVector : Integer -> Integer -> Integer -> ExactVectorSample realThreeSpace -threeVector first second third = +three_vector : Integer → Integer → Integer → ExactVectorSample real_three_space +three_vector first second third = UnsafeVectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second (UnsafeCoordinateCons third UnsafeCoordinateNil))) public export -threeCovector : Integer -> Integer -> Integer -> ExactCovectorSample realThreeSpace -threeCovector first second third = +three_covector : Integer → Integer → Integer → ExactCovectorSample real_three_space +three_covector first second third = UnsafeCovectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second @@ -279,17 +279,17 @@ public export data Variance = Lower | Upper public export -data IndexedValue : Variance -> FiniteSpace -> Type where +data IndexedValue : Variance → FiniteSpace → Type where LowerIndex : - {space : FiniteSpace} -> - ExactCovectorSample space -> IndexedValue Lower space + {space : FiniteSpace} → + ExactCovectorSample space → IndexedValue Lower space UpperIndex : - {space : FiniteSpace} -> - ExactVectorSample space -> IndexedValue Upper space + {space : FiniteSpace} → + ExactVectorSample space → IndexedValue Upper space public export -contractIndex : - {space : FiniteSpace} -> - IndexedValue Lower space -> IndexedValue Upper space -> Integer -contractIndex (LowerIndex covector) (UpperIndex vector) = +contract_index : + {space : FiniteSpace} → + IndexedValue Lower space → IndexedValue Upper space → Integer +contract_index (LowerIndex covector) (UpperIndex vector) = contract covector vector diff --git a/_/examples/unified-higher-mathematics/NamedFacts.idric b/_/examples/unified-higher-mathematics/NamedFacts.idric index 1236571c3d..bf8985b71f 100644 --- a/_/examples/unified-higher-mathematics/NamedFacts.idric +++ b/_/examples/unified-higher-mathematics/NamedFacts.idric @@ -12,37 +12,37 @@ import TopologyFacts public export record FactProvenance where constructor MkFactProvenance - factNamespace : Text - factName : Text - factVersion : Text + fact_namespace : Text + fact_name : Text + fact_version : Text -- A declared code-source locator, not a checked citation. - factSource : Text + fact_source : Text public export data NamedFact : - (hypothesis : Type) -> - (conclusion : hypothesis -> Type) -> + (hypothesis : Type) → + (conclusion : hypothesis → Type) → Type where DeclareNamedFact : - {hypothesis : Type} -> - {conclusion : hypothesis -> Type} -> - FactProvenance -> - ((witness : hypothesis) -> conclusion witness) -> + {hypothesis : Type} → + {conclusion : hypothesis → Type} → + FactProvenance → + ((witness : hypothesis) → conclusion witness) → NamedFact hypothesis conclusion public export -data TypedContext : Type -> Type where +data TypedContext : Type → Type where ContextContains : - {hypothesis : Type} -> - (witness : hypothesis) -> + {hypothesis : Type} → + (witness : hypothesis) → TypedContext hypothesis public export -contextWitness : - {hypothesis : Type} -> - TypedContext hypothesis -> +context_witness : + {hypothesis : Type} → + TypedContext hypothesis → hypothesis -contextWitness (ContextContains witness) = witness +context_witness (ContextContains witness) = witness public export data FactOrigin = NamedFactLookup FactProvenance @@ -50,54 +50,54 @@ data FactOrigin = NamedFactLookup FactProvenance -- This constructor records that the value came through explicit named-fact -- application, not from ordinary unification or dependent-index normalization. public export -data FactAnswer : Type -> Type where +data FactAnswer : Type → Type where FromNamedFact : - {result : Type} -> - FactProvenance -> - result -> + {result : Type} → + FactProvenance → + result → FactAnswer result public export -factConclusion : {result : Type} -> FactAnswer result -> result -factConclusion (FromNamedFact _ conclusion) = conclusion +fact_conclusion : {result : Type} → FactAnswer result → result +fact_conclusion (FromNamedFact _ conclusion) = conclusion public export -answerOrigin : {result : Type} -> FactAnswer result -> FactOrigin -answerOrigin (FromNamedFact provenance _) = NamedFactLookup provenance +answer_origin : {result : Type} → FactAnswer result → FactOrigin +answer_origin (FromNamedFact provenance _) = NamedFactLookup provenance public export -factExplanation : {result : Type} -> FactAnswer result -> Text -factExplanation (FromNamedFact provenance _) = +fact_explanation : {result : Type} → FactAnswer result → Text +fact_explanation (FromNamedFact provenance _) = "named fact " - ++ factNamespace provenance + ++ fact_namespace provenance ++ "." - ++ factName provenance + ++ fact_name provenance ++ "@" - ++ factVersion provenance + ++ fact_version provenance public export -answerProvenance : {result : Type} -> FactAnswer result -> FactProvenance -answerProvenance (FromNamedFact provenance _) = provenance +answer_provenance : {result : Type} → FactAnswer result → FactProvenance +answer_provenance (FromNamedFact provenance _) = provenance public export -lookupNamedFact : - {hypothesis : Type} -> - {conclusion : hypothesis -> Type} -> - (fact : NamedFact hypothesis conclusion) -> - (context : TypedContext hypothesis) -> - FactAnswer (conclusion (contextWitness context)) -lookupNamedFact +lookup_named_fact : + {hypothesis : Type} → + {conclusion : hypothesis → Type} → + (fact : NamedFact hypothesis conclusion) → + (context : TypedContext hypothesis) → + FactAnswer (conclusion (context_witness context)) +lookup_named_fact (DeclareNamedFact provenance derive) (ContextContains witness) = FromNamedFact provenance (derive witness) public export -jordanSeparationFact : NamedFact EmbeddedCircleInS2 JordanSeparation -jordanSeparationFact = +jordan_separation_fact : NamedFact EmbeddedCircleInS2 JordanSeparation +jordan_separation_fact = DeclareNamedFact (MkFactProvenance "topology" "jordan-separation" "1" - "TopologyFacts.jordanSeparation") - jordanSeparation + "TopologyFacts.jordan_separation") + jordan_separation diff --git a/_/examples/unified-higher-mathematics/PresheafRestriction.idric b/_/examples/unified-higher-mathematics/PresheafRestriction.idric index a78a94cb41..eaaf9741aa 100644 --- a/_/examples/unified-higher-mathematics/PresheafRestriction.idric +++ b/_/examples/unified-higher-mathematics/PresheafRestriction.idric @@ -10,20 +10,20 @@ public export data Open = Whole | Patch | Point public export -data Included : Open -> Open -> Type where - Same : {u : Open} -> Included u u +data Included : Open → Open → Type where + Same : {u : Open} → Included u u PatchWhole : Included Patch Whole PointPatch : Included Point Patch PointWhole : Included Point Whole public export -data Section : Open -> Type where - WholeSection : Integer -> Section Whole - PatchSection : Integer -> Section Patch - PointSection : Integer -> Section Point +data Section : Open → Type where + WholeSection : Integer → Section Whole + PatchSection : Integer → Section Patch + PointSection : Integer → Section Point public export -restrict : {u, v : Open} -> Included v u -> Section u -> Section v +restrict : {u, v : Open} → Included v u → Section u → Section v restrict Same section = section restrict PatchWhole (WholeSection value) = PatchSection value restrict PointPatch (PatchSection value) = PointSection value @@ -33,70 +33,70 @@ restrict PointWhole (WholeSection value) = PointSection value -- open. It does not construct a balanced tensor product, sums of elementary -- tensors, or a quotient by bilinearity relations. public export -data ElementaryTensorSection : Open -> Type where +data ElementaryTensorSection : Open → Type where TensorSection : - {u : Open} -> - Section u -> Section u -> ElementaryTensorSection u + {u : Open} → + Section u → Section u → ElementaryTensorSection u public export -restrictTensor : - {u, v : Open} -> - Included v u -> - ElementaryTensorSection u -> +restrict_tensor : + {u, v : Open} → + Included v u → + ElementaryTensorSection u → ElementaryTensorSection v -restrictTensor Same tensor = tensor -restrictTensor inclusion (TensorSection left right) = +restrict_tensor Same tensor = tensor +restrict_tensor inclusion (TensorSection left right) = TensorSection (restrict inclusion left) (restrict inclusion right) public export -tensorRestrictionPointwise : - {u, v : Open} -> - (inclusion : Included v u) -> - (left : Section u) -> - (right : Section u) -> - restrictTensor inclusion (TensorSection left right) +tensor_restriction_pointwise : + {u, v : Open} → + (inclusion : Included v u) → + (left : Section u) → + (right : Section u) → + restrict_tensor inclusion (TensorSection left right) = TensorSection (restrict inclusion left) (restrict inclusion right) -tensorRestrictionPointwise Same left right = Refl -tensorRestrictionPointwise +tensor_restriction_pointwise Same left right = Refl +tensor_restriction_pointwise PatchWhole (WholeSection left) (WholeSection right) = Refl -tensorRestrictionPointwise +tensor_restriction_pointwise PointPatch (PatchSection left) (PatchSection right) = Refl -tensorRestrictionPointwise +tensor_restriction_pointwise PointWhole (WholeSection left) (WholeSection right) = Refl public export -composeIncluded : - {u, v, w : Open} -> Included w v -> Included v u -> Included w u -composeIncluded Same inclusion = inclusion -composeIncluded PatchWhole Same = PatchWhole -composeIncluded PointPatch Same = PointPatch -composeIncluded PointPatch PatchWhole = PointWhole -composeIncluded PointWhole Same = PointWhole +compose_included : + {u, v, w : Open} → Included w v → Included v u → Included w u +compose_included Same inclusion = inclusion +compose_included PatchWhole Same = PatchWhole +compose_included PointPatch Same = PointPatch +compose_included PointPatch PatchWhole = PointWhole +compose_included PointWhole Same = PointWhole -- Identity restriction reduces definitionally, including when the formal pair -- is opaque to the caller. public export -tensorRestrictionIdentity : - {u : Open} -> - (tensor : ElementaryTensorSection u) -> - restrictTensor Same tensor = tensor -tensorRestrictionIdentity tensor = Refl +tensor_restriction_identity : + {u : Open} → + (tensor : ElementaryTensorSection u) → + restrict_tensor Same tensor = tensor +tensor_restriction_identity tensor = Refl public export -tensorRestrictionComposition : - {u, v, w : Open} -> - (wv : Included w v) -> - (vu : Included v u) -> - (tensor : ElementaryTensorSection u) -> - restrictTensor wv (restrictTensor vu tensor) - = restrictTensor (composeIncluded wv vu) tensor -tensorRestrictionComposition Same vu tensor = Refl -tensorRestrictionComposition PatchWhole Same tensor = Refl -tensorRestrictionComposition PointPatch Same tensor = Refl -tensorRestrictionComposition +tensor_restriction_composition : + {u, v, w : Open} → + (wv : Included w v) → + (vu : Included v u) → + (tensor : ElementaryTensorSection u) → + restrict_tensor wv (restrict_tensor vu tensor) + = restrict_tensor (compose_included wv vu) tensor +tensor_restriction_composition Same vu tensor = Refl +tensor_restriction_composition PatchWhole Same tensor = Refl +tensor_restriction_composition PointPatch Same tensor = Refl +tensor_restriction_composition PointPatch PatchWhole (TensorSection (WholeSection left) (WholeSection right)) = Refl -tensorRestrictionComposition PointWhole Same tensor = Refl +tensor_restriction_composition PointWhole Same tensor = Refl diff --git a/_/examples/unified-higher-mathematics/README.md b/_/examples/unified-higher-mathematics/README.md index 6977fe06cb..77745f92df 100644 --- a/_/examples/unified-higher-mathematics/README.md +++ b/_/examples/unified-higher-mathematics/README.md @@ -10,8 +10,8 @@ small, compiler-checked semantic example, not a general mathematics library. name is itself indexed by its rank, so `PlaneName` cannot be reused at rank 128. The complete `FiniteSpace`, rather than its rank alone, indexes `ExactVectorSample`, `ExactCovectorSample`, `IndexedValue`, -`EuclideanStructure`, and the orthogonal types. Consequently `planeSpace` -and `imagePlaneSpace` remain different even though both have rank two. +`EuclideanStructure`, and the orthogonal types. Consequently `plane_space` +and `image_plane_space` remain different even though both have rank two. `ExactVectorSample space` and `ExactCovectorSample space` are separate datatypes. They are explicitly the executable integer-coordinate fragment of @@ -21,7 +21,7 @@ denotes a genuine vector or covector. The metric-free operation is covector evaluation: ```idris -contract : ExactCovectorSample space -> ExactVectorSample space -> Integer +contract : ExactCovectorSample space → ExactVectorSample space → Integer ``` `RawExactCoordinates`, `UnsafeVectorCoordinates`, and the other @@ -33,7 +33,7 @@ API never performs such a conversion silently. There is deliberately no checked vector-to-covector conversion in `MathematicalSpaces`. `EuclideanStructure space` supplies that additional -identification through `lowerIndex` and `raiseIndex`; `dot`, `norm`, +identification through `lower_index` and `raise_index`; `dot`, `norm`, `distance`, and index raising/lowering on exact samples all require the structure explicitly. The current witness is the standard coordinate Euclidean structure. `norm` and `distance` retain an exact symbolic square @@ -44,7 +44,7 @@ real-scalar representation remains deliberately unchosen. Euclidean structure and by `Preserving` or `Reversing`. Its public constructors are restricted to the settled identity, first-axis reflection, first-plane quarter-turn, exact integral unit-quaternion rotation, and -composition. `applyOrthogonalExact` interprets that same closed syntax on +composition. `apply_orthogonal_exact` interprets that same closed syntax on exact samples; composition means `left (right sample)`. This removes the old disconnect between marker values and separate generator evaluators. The orientation indices record the reviewed standard maps; Idric does not derive @@ -56,9 +56,9 @@ arbitrary user-supplied matrix or represent every quaternionic rotation. The Einstein-style experiment is intentionally only a one-index kernel. `LowerIndex` contains a covector, `UpperIndex` contains a vector, and -`contractIndex` accepts opposite variance over the same complete named-space +`contract_index` accepts opposite variance over the same complete named-space index. Equal ranks neither erase a name mismatch nor permit same-variance -contraction. A variance change goes through `lowerIndexed` or `raiseIndexed` +contraction. A variance change goes through `lower_indexed` or `raise_indexed` and therefore requires a Euclidean structure. The finite presheaf example remains in `PresheafRestriction.idric`. It shares @@ -99,7 +99,7 @@ The named-fact proof of concept contains one entry, S^2 and its typed conclusion is the corresponding two-component separation fact. Here the embedding value is an explicit assumption token; no map or injectivity property is inferred or checked. A `NamedFact H C` stores -human-declared attribution plus an Idriç function `(h : H) -> C h`. Lookup +human-declared attribution plus an Idriç function `(h : H) → C h`. Lookup explicitly applies that selected entry to `TypedContext H`; the type checker enforces the exact hypothesis type, and the answer says that it came through named lookup rather than unification. This is the boundary requested by #42 diff --git a/_/examples/unified-higher-mathematics/Tests.idric b/_/examples/unified-higher-mathematics/Tests.idric index 6694c64afe..9c4f011b2a 100644 --- a/_/examples/unified-higher-mathematics/Tests.idric +++ b/_/examples/unified-higher-mathematics/Tests.idric @@ -17,42 +17,42 @@ import NamedFacts -- -------------------------------------------------------------------------- plane_pairing_test : - contract (planeCovector 5 7) (planeVector 3 4) = 43 + contract (plane_covector 5 7) (plane_vector 3 4) = 43 plane_pairing_test = Refl contraction_linear_in_vector_test : contract - (planeCovector 5 7) - (addVector (planeVector 3 4) (planeVector 2 (-1))) - = contract (planeCovector 5 7) (planeVector 3 4) - + contract (planeCovector 5 7) (planeVector 2 (-1)) + (plane_covector 5 7) + (add_vector (plane_vector 3 4) (plane_vector 2 (-1))) + = contract (plane_covector 5 7) (plane_vector 3 4) + + contract (plane_covector 5 7) (plane_vector 2 (-1)) contraction_linear_in_vector_test = Refl contraction_linear_in_covector_test : contract - (addCovector (planeCovector 5 7) (planeCovector (-2) 1)) - (planeVector 3 4) - = contract (planeCovector 5 7) (planeVector 3 4) - + contract (planeCovector (-2) 1) (planeVector 3 4) + (add_covector (plane_covector 5 7) (plane_covector (-2) 1)) + (plane_vector 3 4) + = contract (plane_covector 5 7) (plane_vector 3 4) + + contract (plane_covector (-2) 1) (plane_vector 3 4) contraction_linear_in_covector_test = Refl contraction_respects_vector_scaling_test : contract - (planeCovector 5 7) - (scaleVector 3 (planeVector 3 4)) - = 3 * contract (planeCovector 5 7) (planeVector 3 4) + (plane_covector 5 7) + (scale_vector 3 (plane_vector 3 4)) + = 3 * contract (plane_covector 5 7) (plane_vector 3 4) contraction_respects_vector_scaling_test = Refl contraction_respects_covector_scaling_test : contract - (scaleCovector 3 (planeCovector 5 7)) - (planeVector 3 4) - = 3 * contract (planeCovector 5 7) (planeVector 3 4) + (scale_covector 3 (plane_covector 5 7)) + (plane_vector 3 4) + = 3 * contract (plane_covector 5 7) (plane_vector 3 4) contraction_respects_covector_scaling_test = Refl failing "Mismatch between: PlaneName and ImagePlaneName." - equal_rank_named_spaces_do_not_unify : ExactVectorSample imagePlaneSpace - equal_rank_named_spaces_do_not_unify = planeVector 1 2 + equal_rank_named_spaces_do_not_unify : ExactVectorSample image_plane_space + equal_rank_named_spaces_do_not_unify = plane_vector 1 2 failing "Mismatch between: 0 and 1." one_name_cannot_claim_a_different_rank : FiniteSpace @@ -62,54 +62,54 @@ failing "Mismatch between: 0 and 1." failing "Mismatch between: RealThreeName and PlaneName." mismatched_dimension_contraction : Integer mismatched_dimension_contraction = - contract (planeCovector 1 2) (threeVector 3 4 5) + contract (plane_covector 1 2) (three_vector 3 4 5) failing "Mismatch between: ImagePlaneName and PlaneName." equal_rank_mismatched_space_contraction : Integer equal_rank_mismatched_space_contraction = - contract (planeCovector 1 2) (imagePlaneVector 3 4) + contract (plane_covector 1 2) (image_plane_vector 3 4) -failing "Mismatch between: ExactVectorSample planeSpace and ExactCovectorSample" +failing "Mismatch between: ExactVectorSample plane_space and ExactCovectorSample" vector_vector_contraction_without_euclidean_structure : Integer vector_vector_contraction_without_euclidean_structure = - contract (planeVector 1 2) (planeVector 3 4) + contract (plane_vector 1 2) (plane_vector 3 4) -- -------------------------------------------------------------------------- -- Explicit Euclidean structure -- -------------------------------------------------------------------------- metric_lowers_vector_test : - lowerIndex planeEuclidean (planeVector 3 4) = planeCovector 3 4 + lower_index plane_euclidean (plane_vector 3 4) = plane_covector 3 4 metric_lowers_vector_test = Refl metric_raises_covector_test : - raiseIndex planeEuclidean (planeCovector 3 4) = planeVector 3 4 + raise_index plane_euclidean (plane_covector 3 4) = plane_vector 3 4 metric_raises_covector_test = Refl metric_dot_test : - dot planeEuclidean (planeVector 3 4) (planeVector 5 7) = 43 + dot plane_euclidean (plane_vector 3 4) (plane_vector 5 7) = 43 metric_dot_test = Refl metric_squared_norm_test : - squaredNorm planeEuclidean (planeVector 3 4) = 25 + squared_norm plane_euclidean (plane_vector 3 4) = 25 metric_squared_norm_test = Refl metric_norm_test : - norm planeEuclidean (planeVector 3 4) = SquareRoot 25 + norm plane_euclidean (plane_vector 3 4) = SquareRoot 25 metric_norm_test = Refl metric_squared_distance_test : - squaredDistance - planeEuclidean - (planeVector 5 7) - (planeVector 2 3) = 25 + squared_distance + plane_euclidean + (plane_vector 5 7) + (plane_vector 2 3) = 25 metric_squared_distance_test = Refl metric_distance_test : distance - planeEuclidean - (planeVector 5 7) - (planeVector 2 3) = SquareRoot 25 + plane_euclidean + (plane_vector 5 7) + (plane_vector 2 3) = SquareRoot 25 metric_distance_test = Refl -- -------------------------------------------------------------------------- @@ -117,34 +117,34 @@ metric_distance_test = Refl -- -------------------------------------------------------------------------- named_index_contraction_test : - contractIndex - (LowerIndex (planeCovector 5 7)) - (UpperIndex (planeVector 3 4)) = 43 + contract_index + (LowerIndex (plane_covector 5 7)) + (UpperIndex (plane_vector 3 4)) = 43 named_index_contraction_test = Refl failing "Mismatch between: Lower and Upper." same_variance_index_contraction : Integer same_variance_index_contraction = - contractIndex - (LowerIndex (planeCovector 5 7)) - (LowerIndex (planeCovector 3 4)) + contract_index + (LowerIndex (plane_covector 5 7)) + (LowerIndex (plane_covector 3 4)) failing "Mismatch between: ImagePlaneName and PlaneName." equal_rank_named_index_space_mismatch : Integer equal_rank_named_index_space_mismatch = - contractIndex - (LowerIndex (planeCovector 5 7)) - (UpperIndex (imagePlaneVector 3 4)) + contract_index + (LowerIndex (plane_covector 5 7)) + (UpperIndex (image_plane_vector 3 4)) metric_driven_index_lowering_test : - contractIndex - (lowerIndexed planeEuclidean (UpperIndex (planeVector 5 7))) - (UpperIndex (planeVector 3 4)) = 43 + contract_index + (lower_indexed plane_euclidean (UpperIndex (plane_vector 5 7))) + (UpperIndex (plane_vector 3 4)) = 43 metric_driven_index_lowering_test = Refl metric_driven_index_raising_test : - raiseIndexed planeEuclidean (LowerIndex (planeCovector 3 4)) - = UpperIndex (planeVector 3 4) + raise_indexed plane_euclidean (LowerIndex (plane_covector 3 4)) + = UpperIndex (plane_vector 3 4) metric_driven_index_raising_test = Refl -- -------------------------------------------------------------------------- @@ -160,200 +160,200 @@ metric_driven_index_raising_test = Refl -- state all 128 coordinates; semantic clients use the named constructors and -- checked contraction/metric operations above. -lastCoordinate : (n : Number) -> Integer -> RawExactCoordinates (S n) -lastCoordinate Z value = UnsafeCoordinateCons value UnsafeCoordinateNil -lastCoordinate (S n) value = - UnsafeCoordinateCons 0 (lastCoordinate n value) +last_coordinate : (n : Number) → Integer → RawExactCoordinates (S n) +last_coordinate Z value = UnsafeCoordinateCons value UnsafeCoordinateNil +last_coordinate (S n) value = + UnsafeCoordinateCons 0 (last_coordinate n value) r128_sample_tail : RawExactCoordinates 126 r128_sample_tail = - unsafeAddCoordinates - (UnsafeCoordinateCons 12 (unsafeZeroCoordinates 125)) - (lastCoordinate 125 9) + unsafe_add_coordinates + (UnsafeCoordinateCons 12 (unsafe_zero_coordinates 125)) + (last_coordinate 125 9) r128_companion_tail : RawExactCoordinates 126 r128_companion_tail = - unsafeAddCoordinates - (UnsafeCoordinateCons 7 (unsafeZeroCoordinates 125)) - (lastCoordinate 125 11) + unsafe_add_coordinates + (UnsafeCoordinateCons 7 (unsafe_zero_coordinates 125)) + (last_coordinate 125 11) -r128_sample : ExactVectorSample real128Space +r128_sample : ExactVectorSample real128_space r128_sample = UnsafeVectorCoordinates (UnsafeCoordinateCons 3 (UnsafeCoordinateCons 4 r128_sample_tail)) -r128_companion : ExactVectorSample real128Space +r128_companion : ExactVectorSample real128_space r128_companion = UnsafeVectorCoordinates (UnsafeCoordinateCons 5 (UnsafeCoordinateCons (-2) r128_companion_tail)) reflection_in_r128_type_test : - OrthogonalTransform real128Euclidean Reversing -reflection_in_r128_type_test = firstAxisReflection real128Euclidean + OrthogonalTransform real128_euclidean Reversing +reflection_in_r128_type_test = first_axis_reflection real128_euclidean -quarter_turn_in_r128_type_test : SpecialOrthogonal real128Euclidean -quarter_turn_in_r128_type_test = firstPlaneQuarterTurn real128Euclidean +quarter_turn_in_r128_type_test : SpecialOrthogonal real128_euclidean +quarter_turn_in_r128_type_test = first_plane_quarter_turn real128_euclidean -two_reflections_land_in_so128_test : SpecialOrthogonal real128Euclidean +two_reflections_land_in_so128_test : SpecialOrthogonal real128_euclidean two_reflections_land_in_so128_test = - twoReflections - (firstAxisReflection real128Euclidean) - (firstAxisReflection real128Euclidean) + two_reflections + (first_axis_reflection real128_euclidean) + (first_axis_reflection real128_euclidean) r128_orthogonal_identity_action_test : - applyOrthogonalExact OrthogonalIdentity r128_sample = r128_sample + apply_orthogonal_exact OrthogonalIdentity r128_sample = r128_sample r128_orthogonal_identity_action_test = Refl r128_two_reflections_action_test : - applySpecialOrthogonalExact + apply_special_orthogonal_exact two_reflections_land_in_so128_test r128_sample = r128_sample r128_two_reflections_action_test = Refl orthogonal_composition_order_test : - applyOrthogonalExact - (composeOrthogonal - (firstAxisReflection planeEuclidean) - (soTransform (firstPlaneQuarterTurn planeEuclidean))) - (planeVector 2 3) = planeVector 3 2 + apply_orthogonal_exact + (compose_orthogonal + (first_axis_reflection plane_euclidean) + (special_orthogonal_transform (first_plane_quarter_turn plane_euclidean))) + (plane_vector 2 3) = plane_vector 3 2 orthogonal_composition_order_test = Refl r128_reflection_exact_image_test : - applyFirstAxisReflection real128Euclidean r128_sample + apply_first_axis_reflection real128_euclidean r128_sample = UnsafeVectorCoordinates (UnsafeCoordinateCons (-3) (UnsafeCoordinateCons 4 r128_sample_tail)) r128_reflection_exact_image_test = Refl r128_quarter_turn_exact_image_test : - applyFirstPlaneQuarterTurn real128Euclidean r128_sample + apply_first_plane_quarter_turn real128_euclidean r128_sample = UnsafeVectorCoordinates (UnsafeCoordinateCons (-4) (UnsafeCoordinateCons 3 r128_sample_tail)) r128_quarter_turn_exact_image_test = Refl r128_reflection_preserves_squared_norm_test : - squaredNorm - real128Euclidean - (applyFirstAxisReflection real128Euclidean r128_sample) = 250 + squared_norm + real128_euclidean + (apply_first_axis_reflection real128_euclidean r128_sample) = 250 r128_reflection_preserves_squared_norm_test = Refl r128_quarter_turn_preserves_squared_norm_test : - squaredNorm - real128Euclidean - (applyFirstPlaneQuarterTurn real128Euclidean r128_sample) = 250 + squared_norm + real128_euclidean + (apply_first_plane_quarter_turn real128_euclidean r128_sample) = 250 r128_quarter_turn_preserves_squared_norm_test = Refl r128_reflection_preserves_dot_test : dot - real128Euclidean - (applyFirstAxisReflection real128Euclidean r128_sample) - (applyFirstAxisReflection real128Euclidean r128_companion) = 190 + real128_euclidean + (apply_first_axis_reflection real128_euclidean r128_sample) + (apply_first_axis_reflection real128_euclidean r128_companion) = 190 r128_reflection_preserves_dot_test = Refl r128_quarter_turn_preserves_dot_test : dot - real128Euclidean - (applyFirstPlaneQuarterTurn real128Euclidean r128_sample) - (applyFirstPlaneQuarterTurn real128Euclidean r128_companion) = 190 + real128_euclidean + (apply_first_plane_quarter_turn real128_euclidean r128_sample) + (apply_first_plane_quarter_turn real128_euclidean r128_companion) = 190 r128_quarter_turn_preserves_dot_test = Refl r128_reflection_is_involution_test : - applyFirstAxisReflection - real128Euclidean - (applyFirstAxisReflection real128Euclidean r128_sample) = r128_sample + apply_first_axis_reflection + real128_euclidean + (apply_first_axis_reflection real128_euclidean r128_sample) = r128_sample r128_reflection_is_involution_test = Refl r128_four_quarter_turns_are_identity_test : - applyFirstPlaneQuarterTurn real128Euclidean - (applyFirstPlaneQuarterTurn real128Euclidean - (applyFirstPlaneQuarterTurn real128Euclidean - (applyFirstPlaneQuarterTurn real128Euclidean r128_sample))) + apply_first_plane_quarter_turn real128_euclidean + (apply_first_plane_quarter_turn real128_euclidean + (apply_first_plane_quarter_turn real128_euclidean + (apply_first_plane_quarter_turn real128_euclidean r128_sample))) = r128_sample r128_four_quarter_turns_are_identity_test = Refl -lastCoordinateValue : {n : Number} -> RawExactCoordinates (S n) -> Integer -lastCoordinateValue (UnsafeCoordinateCons value UnsafeCoordinateNil) = value -lastCoordinateValue - (UnsafeCoordinateCons _ rest@(UnsafeCoordinateCons _ _)) = lastCoordinateValue rest +last_coordinate_value : {n : Number} → RawExactCoordinates (S n) → Integer +last_coordinate_value (UnsafeCoordinateCons value UnsafeCoordinateNil) = value +last_coordinate_value + (UnsafeCoordinateCons _ rest@(UnsafeCoordinateCons _ _)) = last_coordinate_value rest r128_reflection_preserves_coordinate_128_test : - lastCoordinateValue - (unsafeCoordinatesOfVector - (applyFirstAxisReflection real128Euclidean r128_sample)) = 9 + last_coordinate_value + (unsafe_coordinates_of_vector + (apply_first_axis_reflection real128_euclidean r128_sample)) = 9 r128_reflection_preserves_coordinate_128_test = Refl r128_quarter_turn_preserves_coordinate_128_test : - lastCoordinateValue - (unsafeCoordinatesOfVector - (applyFirstPlaneQuarterTurn real128Euclidean r128_sample)) = 9 + last_coordinate_value + (unsafe_coordinates_of_vector + (apply_first_plane_quarter_turn real128_euclidean r128_sample)) = 9 r128_quarter_turn_preserves_coordinate_128_test = Refl -- -------------------------------------------------------------------------- -- Surviving geometry and topology facts from #45 -- -------------------------------------------------------------------------- -north_pole_is_s2_test : UnitSpherePoint realThreeEuclidean -north_pole_is_s2_test = northPoleS2 +north_pole_is_s2_test : UnitSpherePoint real_three_euclidean +north_pole_is_s2_test = north_pole_s2 -sphere_s0_h0_rank_test : sphereIntegralCohomologyRank 0 0 = 2 +sphere_s0_h0_rank_test : sphere_integral_cohomology_rank 0 0 = 2 sphere_s0_h0_rank_test = Refl -sphere_s2_h0_rank_test : sphereIntegralCohomologyRank 2 0 = 1 +sphere_s2_h0_rank_test : sphere_integral_cohomology_rank 2 0 = 1 sphere_s2_h0_rank_test = Refl -sphere_s2_h1_rank_test : sphereIntegralCohomologyRank 2 1 = 0 +sphere_s2_h1_rank_test : sphere_integral_cohomology_rank 2 1 = 0 sphere_s2_h1_rank_test = Refl -sphere_s2_h2_rank_test : sphereIntegralCohomologyRank 2 2 = 1 +sphere_s2_h2_rank_test : sphere_integral_cohomology_rank 2 2 = 1 sphere_s2_h2_rank_test = Refl -odd_sphere_euler_test : sphereEulerCharacteristic 3 = 0 +odd_sphere_euler_test : sphere_euler_characteristic 3 = 0 odd_sphere_euler_test = Refl -even_sphere_euler_test : sphereEulerCharacteristic 4 = 2 +even_sphere_euler_test : sphere_euler_characteristic 4 = 2 even_sphere_euler_test = Refl -quaternion_i_j_test : quaternionMultiply quatI quatJ = quatK +quaternion_i_j_test : quaternion_multiply quaternion_i quaternion_j = quaternion_k quaternion_i_j_test = Refl quaternion_j_i_test : - quaternionMultiply quatJ quatI = quaternionNegate quatK + quaternion_multiply quaternion_j quaternion_i = quaternion_negate quaternion_k quaternion_j_i_test = Refl -quaternion_i_norm_test : quaternionNormSquared quatI = 1 +quaternion_i_norm_test : quaternion_norm_squared quaternion_i = 1 quaternion_i_norm_test = Refl -unit_quaternion_rotation_is_so3_test : SpecialOrthogonal realThreeEuclidean -unit_quaternion_rotation_is_so3_test = quaternionRotation unitQuatI +unit_quaternion_rotation_is_so3_test : SpecialOrthogonal real_three_euclidean +unit_quaternion_rotation_is_so3_test = quaternion_rotation unit_quaternion_i unit_quaternion_rotation_action_test : - applySpecialOrthogonalExact - (quaternionRotation unitQuatI) - (threeVector 0 1 0) = threeVector 0 (-1) 0 + apply_special_orthogonal_exact + (quaternion_rotation unit_quaternion_i) + (three_vector 0 1 0) = three_vector 0 (-1) 0 unit_quaternion_rotation_action_test = Refl -cp3_real_dimension_test : cpRealDimension 3 = 6 +cp3_real_dimension_test : cp_real_dimension 3 = 6 cp3_real_dimension_test = Refl -cp3_hopf_sphere_dimension_test : cpHopfSphereDimension 3 = 7 +cp3_hopf_sphere_dimension_test : cp_hopf_sphere_dimension 3 = 7 cp3_hopf_sphere_dimension_test = Refl -cp2_h0_rank_test : cpIntegralCohomologyRank 2 0 = 1 +cp2_h0_rank_test : cp_integral_cohomology_rank 2 0 = 1 cp2_h0_rank_test = Refl -cp2_h2_rank_test : cpIntegralCohomologyRank 2 2 = 1 +cp2_h2_rank_test : cp_integral_cohomology_rank 2 2 = 1 cp2_h2_rank_test = Refl -cp2_h4_rank_test : cpIntegralCohomologyRank 2 4 = 1 +cp2_h4_rank_test : cp_integral_cohomology_rank 2 4 = 1 cp2_h4_rank_test = Refl -cp2_h3_rank_test : cpIntegralCohomologyRank 2 3 = 0 +cp2_h3_rank_test : cp_integral_cohomology_rank 2 3 = 0 cp2_h3_rank_test = Refl -cp2_h6_rank_test : cpIntegralCohomologyRank 2 6 = 0 +cp2_h6_rank_test : cp_integral_cohomology_rank 2 6 = 0 cp2_h6_rank_test = Refl r3_one_point_compactifies_to_s3_test : - compactifiedSphereDimension (euclideanOnePointCompactification 3) = 3 + compactified_sphere_dimension (euclidean_one_point_compactification 3) = 3 r3_one_point_compactifies_to_s3_test = Refl -- -------------------------------------------------------------------------- @@ -364,77 +364,77 @@ whole_tensor : ElementaryTensorSection Whole whole_tensor = TensorSection (WholeSection 2) (WholeSection 3) tensor_restriction_infers_open_test : ElementaryTensorSection Patch -tensor_restriction_infers_open_test = restrictTensor PatchWhole whole_tensor +tensor_restriction_infers_open_test = restrict_tensor PatchWhole whole_tensor tensor_restriction_identity_test : - restrictTensor Same tensor_restriction_infers_open_test + restrict_tensor Same tensor_restriction_infers_open_test = tensor_restriction_infers_open_test tensor_restriction_identity_test = Refl tensor_restriction_composition_test : - restrictTensor PointPatch (restrictTensor PatchWhole whole_tensor) - = restrictTensor PointWhole whole_tensor + restrict_tensor PointPatch (restrict_tensor PatchWhole whole_tensor) + = restrict_tensor PointWhole whole_tensor tensor_restriction_composition_test = Refl tensor_restriction_componentwise_test : - restrictTensor PatchWhole whole_tensor + restrict_tensor PatchWhole whole_tensor = TensorSection (PatchSection 2) (PatchSection 3) tensor_restriction_componentwise_test = - tensorRestrictionPointwise PatchWhole (WholeSection 2) (WholeSection 3) + tensor_restriction_pointwise PatchWhole (WholeSection 2) (WholeSection 3) -- -------------------------------------------------------------------------- -- Tiny provenance-aware named-fact boundary -- -------------------------------------------------------------------------- jordan_context : TypedContext EmbeddedCircleInS2 -jordan_context = ContextContains jordanCurveExample +jordan_context = ContextContains jordan_curve_example -jordan_lookup_test : FactAnswer (JordanSeparation jordanCurveExample) -jordan_lookup_test = lookupNamedFact jordanSeparationFact jordan_context +jordan_lookup_test : FactAnswer (JordanSeparation jordan_curve_example) +jordan_lookup_test = lookup_named_fact jordan_separation_fact jordan_context -unrelated_context : TypedContext (ExactVectorSample planeSpace) -unrelated_context = ContextContains (planeVector 1 2) +unrelated_context : TypedContext (ExactVectorSample plane_space) +unrelated_context = ContextContains (plane_vector 1 2) -failing "Mismatch between: ExactVectorSample planeSpace and EmbeddedCircleInS2." +failing "Mismatch between: ExactVectorSample plane_space and EmbeddedCircleInS2." named_fact_rejects_unrelated_context : - FactAnswer (JordanSeparation jordanCurveExample) + FactAnswer (JordanSeparation jordan_curve_example) named_fact_rejects_unrelated_context = - lookupNamedFact jordanSeparationFact unrelated_context + lookup_named_fact jordan_separation_fact unrelated_context jordan_lookup_conclusion_test : - complementComponentCount (factConclusion jordan_lookup_test) = 2 + complement_component_count (fact_conclusion jordan_lookup_test) = 2 jordan_lookup_conclusion_test = Refl jordan_lookup_explanation_test : - factExplanation jordan_lookup_test + fact_explanation jordan_lookup_test = "named fact topology.jordan-separation@1" jordan_lookup_explanation_test = Refl jordan_lookup_origin_test : - answerOrigin jordan_lookup_test + answer_origin jordan_lookup_test = NamedFactLookup (MkFactProvenance "topology" "jordan-separation" "1" - "TopologyFacts.jordanSeparation") + "TopologyFacts.jordan_separation") jordan_lookup_origin_test = Refl jordan_lookup_namespace_test : - factNamespace (answerProvenance jordan_lookup_test) = "topology" + fact_namespace (answer_provenance jordan_lookup_test) = "topology" jordan_lookup_namespace_test = Refl jordan_lookup_name_test : - factName (answerProvenance jordan_lookup_test) = "jordan-separation" + fact_name (answer_provenance jordan_lookup_test) = "jordan-separation" jordan_lookup_name_test = Refl jordan_lookup_version_test : - factVersion (answerProvenance jordan_lookup_test) = "1" + fact_version (answer_provenance jordan_lookup_test) = "1" jordan_lookup_version_test = Refl jordan_lookup_source_test : - factSource (answerProvenance jordan_lookup_test) - = "TopologyFacts.jordanSeparation" + fact_source (answer_provenance jordan_lookup_test) + = "TopologyFacts.jordan_separation" jordan_lookup_source_test = Refl main : IO () diff --git a/_/examples/unified-higher-mathematics/TopologyFacts.idric b/_/examples/unified-higher-mathematics/TopologyFacts.idric index cd200f1f43..c7d4d0e1d6 100644 --- a/_/examples/unified-higher-mathematics/TopologyFacts.idric +++ b/_/examples/unified-higher-mathematics/TopologyFacts.idric @@ -23,53 +23,53 @@ import EuclideanGeometry -- a separate extension. public export data UnitSpherePoint : - {space : FiniteSpace} -> EuclideanStructure space -> Type where + {space : FiniteSpace} → EuclideanStructure space → Type where CheckedUnitSpherePoint : - {space : FiniteSpace} -> - {structure : EuclideanStructure space} -> - (coordinates : ExactVectorSample space) -> - squaredNorm structure coordinates = 1 -> + {space : FiniteSpace} → + {structure : EuclideanStructure space} → + (coordinates : ExactVectorSample space) → + squared_norm structure coordinates = 1 → UnitSpherePoint structure -- S^2 is represented in the named Euclidean R^3 fixture. The norm-one -- certificate is definitional for this exact coordinate sample. public export -northPoleS2 : UnitSpherePoint realThreeEuclidean -northPoleS2 = - CheckedUnitSpherePoint (threeVector 0 0 1) Refl +north_pole_s2 : UnitSpherePoint real_three_euclidean +north_pole_s2 = + CheckedUnitSpherePoint (three_vector 0 0 1) Refl -- Additive integral cohomology ranks of ordinary spheres. S^0 is handled -- separately because it has two connected components. For positive n the -- only nonzero ranks are in degrees 0 and n. This is a closed standard fact, -- not a general cohomology calculation. public export -sphereIntegralCohomologyRank : Number -> Number -> Number -sphereIntegralCohomologyRank Z Z = 2 -sphereIntegralCohomologyRank Z (S degree) = 0 -sphereIntegralCohomologyRank (S dimension) Z = 1 -sphereIntegralCohomologyRank (S dimension) (S degree) = +sphere_integral_cohomology_rank : Number → Number → Number +sphere_integral_cohomology_rank Z Z = 2 +sphere_integral_cohomology_rank Z (S degree) = 0 +sphere_integral_cohomology_rank (S dimension) Z = 1 +sphere_integral_cohomology_rank (S dimension) (S degree) = if dimension == degree then 1 else 0 public export data Parity = Even | Odd public export -flipParity : Parity -> Parity -flipParity Even = Odd -flipParity Odd = Even +flip_parity : Parity → Parity +flip_parity Even = Odd +flip_parity Odd = Even public export -natParity : Number -> Parity -natParity Z = Even -natParity (S n) = flipParity (natParity n) +number_parity : Number → Parity +number_parity Z = Even +number_parity (S n) = flip_parity (number_parity n) -- chi(S^n) = 1 + (-1)^n. public export -sphereEulerCharacteristic : Number -> Integer -sphereEulerCharacteristic dimension = - case natParity dimension of - Even => 2 - Odd => 0 +sphere_euler_characteristic : Number → Integer +sphere_euler_characteristic dimension = + case number_parity dimension of + Even ⇒ 2 + Odd ⇒ 0 -- -------------------------------------------------------------------------- -- Complex projective-space facts @@ -77,34 +77,34 @@ sphereEulerCharacteristic dimension = -- CP^n has complex dimension n and real dimension 2n. public export -cpRealDimension : Number -> Number -cpRealDimension n = n + n +cp_real_dimension : Number → Number +cp_real_dimension n = n + n -- CP^n has the standard Hopf presentation S^(2n+1) / S^1. This returns the -- dimension of the sphere in that presentation; it does not implement quotient -- equality or construct projective space. public export -cpHopfSphereDimension : Number -> Number -cpHopfSphereDimension n = S (n + n) +cp_hopf_sphere_dimension : Number → Number +cp_hopf_sphere_dimension n = S (n + n) -- Additive integral cohomology ranks of CP^n are one in even degrees -- 0,2,...,2n and zero otherwise. The ring structure is deliberately outside -- this small fact table. public export -cpIntegralCohomologyRank : Number -> Number -> Number -cpIntegralCohomologyRank n Z = 1 -cpIntegralCohomologyRank Z (S degree) = 0 -cpIntegralCohomologyRank (S n) (S Z) = 0 -cpIntegralCohomologyRank (S n) (S (S degree)) = - cpIntegralCohomologyRank n degree +cp_integral_cohomology_rank : Number → Number → Number +cp_integral_cohomology_rank n Z = 1 +cp_integral_cohomology_rank Z (S degree) = 0 +cp_integral_cohomology_rank (S n) (S Z) = 0 +cp_integral_cohomology_rank (S n) (S (S degree)) = + cp_integral_cohomology_rank n degree public export -data HopfQuotientFact : Number -> Type where - CPnAsSphereByCircle : (n : Number) -> HopfQuotientFact n +data HopfQuotientFact : Number → Type where + CPnAsSphereByCircle : (n : Number) → HopfQuotientFact n public export -cpHopfQuotient : (n : Number) -> HopfQuotientFact n -cpHopfQuotient n = CPnAsSphereByCircle n +cp_hopf_quotient : (n : Number) → HopfQuotientFact n +cp_hopf_quotient n = CPnAsSphereByCircle n -- -------------------------------------------------------------------------- -- Named theorem-boundary facts @@ -119,39 +119,39 @@ public export data EmbeddedCircleInS2 = MkJordanCurveExample public export -jordanCurveExample : EmbeddedCircleInS2 -jordanCurveExample = MkJordanCurveExample +jordan_curve_example : EmbeddedCircleInS2 +jordan_curve_example = MkJordanCurveExample public export -data JordanSeparation : EmbeddedCircleInS2 -> Type where +data JordanSeparation : EmbeddedCircleInS2 → Type where ExactlyTwoComplementComponents : - (curve : EmbeddedCircleInS2) -> JordanSeparation curve + (curve : EmbeddedCircleInS2) → JordanSeparation curve public export -jordanSeparation : - (curve : EmbeddedCircleInS2) -> JordanSeparation curve -jordanSeparation curve = ExactlyTwoComplementComponents curve +jordan_separation : + (curve : EmbeddedCircleInS2) → JordanSeparation curve +jordan_separation curve = ExactlyTwoComplementComponents curve public export -complementComponentCount : - {curve : EmbeddedCircleInS2} -> JordanSeparation curve -> Number -complementComponentCount (ExactlyTwoComplementComponents curve) = 2 +complement_component_count : + {curve : EmbeddedCircleInS2} → JordanSeparation curve → Number +complement_component_count (ExactlyTwoComplementComponents curve) = 2 -- The one-point compactification of Euclidean R^n is S^n. The family is -- indexed explicitly so this fact cannot be mistaken for a generic -- compactification operation on arbitrary spaces. public export -data EuclideanCompactificationFact : Number -> Type where +data EuclideanCompactificationFact : Number → Type where EuclideanPlusIsSphere : - (dimension : Number) -> EuclideanCompactificationFact dimension + (dimension : Number) → EuclideanCompactificationFact dimension public export -euclideanOnePointCompactification : - (dimension : Number) -> EuclideanCompactificationFact dimension -euclideanOnePointCompactification dimension = +euclidean_one_point_compactification : + (dimension : Number) → EuclideanCompactificationFact dimension +euclidean_one_point_compactification dimension = EuclideanPlusIsSphere dimension public export -compactifiedSphereDimension : - {n : Number} -> EuclideanCompactificationFact n -> Number -compactifiedSphereDimension (EuclideanPlusIsSphere dimension) = dimension +compactified_sphere_dimension : + {n : Number} → EuclideanCompactificationFact n → Number +compactified_sphere_dimension (EuclideanPlusIsSphere dimension) = dimension diff --git a/_/tests/idris2/basic/edric003/Main.idric b/_/tests/idris2/basic/edric003/Main.idric index 1d41523de3..fbca646de8 100644 --- a/_/tests/idris2/basic/edric003/Main.idric +++ b/_/tests/idris2/basic/edric003/Main.idric @@ -2,26 +2,26 @@ module Main import WegertTouch -describe_existing : existing_touch_target -> Text +describe_existing : existing_touch_target → Text describe_existing (fixed_value value) = "fixed_value " ++ show value describe_existing (zero value) = "zero " ++ show value describe_existing (pole value) = "pole " ++ show value -describe_beginning : touch_beginning -> Text +describe_beginning : touch_beginning → Text describe_beginning (near_existing target) = "near_existing (" ++ describe_existing target ++ ")" describe_beginning empty_domain = "empty_domain" -describe_placement : placement_kind -> Text +describe_placement : placement_kind → Text describe_placement new_zero = "new_zero" describe_placement new_pole = "new_pole" -chain_depth : recursive_chain -> Number +chain_depth : recursive_chain → Number chain_depth chain_end = Z chain_depth (chain_link chain_end) = 1 chain_depth (chain_link (chain_link rest)) = 2 + chain_depth rest -identity : a -> a +identity : a → a identity value = value main : IO () From 8ab9a0fff246d6f798761778c398f2e461be6407 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 13:45:24 -0400 Subject: [PATCH 40/80] =?UTF-8?q?Define=20Number=20and=20=C2=B1Number=20se?= =?UTF-8?q?mantics?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Idris/Desugar.idr | 42 ++++++- Idris/Parser.idr | 5 + Idris/Pretty.idr | 1 + Idris/Syntax.idr | 5 +- Idris/Syntax/Traversals.idr | 3 + Parser/Lexer/Source.idr | 5 +- Parser/Rule/Source.idr | 9 ++ Parser/Source.idr | 7 +- STYLE.md | 21 ++-- _/BRANCHES.md | 4 +- _/EDRIC.md | 47 +++++--- _/edric | 1 + .../EuclideanGeometry.idric | 28 ++--- .../HIGH_DIMENSIONAL_VERIFICATION.md | 4 +- .../MathematicalSpaces.idric | 58 +++++----- .../PresheafRestriction.idric | 6 +- .../unified-higher-mathematics/README.md | 6 +- .../unified-higher-mathematics/Tests.idric | 77 ++++++------- .../TopologyFacts.idric | 56 +++++++--- .../exercise/Main.idric | 2 +- .../expected-diagnostic | 2 +- _/koans/01-values-types-and-holes/holes | 2 +- .../solution/Main.idric | 2 +- .../exercise/Main.idric | 2 +- .../expected | 2 +- .../solution/Main.idric | 2 +- .../exercise/Main.idric | 4 +- .../solution/Main.idric | 2 +- .../07-erased-arguments/expected-diagnostic | 2 +- .../exercise/Main.idric | 2 +- .../solution/Main.idric | 2 +- .../exercise/IdrisCompatibility.idr | 4 +- .../11-source-boundaries/exercise/Main.idric | 2 +- .../solution/IdrisCompatibility.idr | 4 +- .../11-source-boundaries/solution/Main.idric | 2 +- _/koans/12-wegert-model/exercise/Main.idric | 10 +- _/koans/12-wegert-model/solution/Main.idric | 10 +- _/libs/prelude/Prelude/Cast.idr | 14 +++ _/libs/prelude/Prelude/Num.idr | 38 +++++++ _/libs/prelude/Prelude/Ops.idr | 2 + _/libs/prelude/Prelude/Show.idr | 8 ++ _/libs/prelude/Prelude/Types.idr | 104 ++++++++++++++++++ _/tests/idris2/basic/edric003/Main.idric | 4 +- .../idris2/basic/edric003/WegertTouch.idric | 10 +- _/tests/idris2/basic/edric005/Main.idric | 6 +- .../basic/edric010/IdrisCompatibility.idr | 10 ++ .../basic/edric010/NegativeIsNotNumber.idric | 4 + _/tests/idris2/basic/edric010/Valid.idric | 34 ++++++ .../basic/edric010/ZeroIsNotNumber.idric | 4 + _/tests/idris2/basic/edric010/expected | 4 + _/tests/idris2/basic/edric010/run | 28 +++++ 51 files changed, 539 insertions(+), 174 deletions(-) create mode 100644 _/tests/idris2/basic/edric010/IdrisCompatibility.idr create mode 100644 _/tests/idris2/basic/edric010/NegativeIsNotNumber.idric create mode 100644 _/tests/idris2/basic/edric010/Valid.idric create mode 100644 _/tests/idris2/basic/edric010/ZeroIsNotNumber.idric create mode 100644 _/tests/idris2/basic/edric010/expected create mode 100755 _/tests/idris2/basic/edric010/run diff --git a/Idris/Desugar.idr b/Idris/Desugar.idr index cb373f0617..52c1561ded 100644 --- a/Idris/Desugar.idr +++ b/Idris/Desugar.idr @@ -129,7 +129,7 @@ checkConflictingFixities isPrefix opn (True, ((fxName, fx) :: _), _) => do -- in the prefix case, remove conflicts with infix (-) - let extraFixities = pre ++ (filter (\(nm, _) => not $ nameRoot nm == "-") inf) + let extraFixities = pre ++ (filter (\(nm, _) => not $ isNegationOperator nm) inf) unless (isCompatible fx extraFixities) $ warnConflict fxName extraFixities pure (mkPrec fx.fix fx.precedence, DeclaredFixity fx) -- Could not find any prefix operator fixities, there may still be conflicts with @@ -138,7 +138,7 @@ checkConflictingFixities isPrefix opn (False, _, ((fxName, fx) :: _)) => do -- In the infix case, remove conflicts with prefix (-) - let extraFixities = (filter (\(nm, _) => not $ nm == UN (Basic "-")) pre) ++ inf + let extraFixities = (filter (\(nm, _) => not $ isNegationOperator nm) pre) ++ inf unless (isCompatible fx extraFixities) $ warnConflict fxName extraFixities pure (mkPrec fx.fix fx.precedence, DeclaredFixity fx) -- Could not find any infix operator fixities, there may be prefix ones @@ -152,6 +152,9 @@ checkConflictingFixities isPrefix opn && fx.precedence == fx'.precedence && fx.bindingInfo == fx'.bindingInfo) . map snd + isNegationOperator : Name -> Bool + isNegationOperator name = nameRoot name == "-" || nameRoot name == "-~-" + -- Emits a warning using the fixity that we picked and the list of all conflicting fixities warnConflict : (picked : Name) -> (conflicts : List (Name, FixityInfo)) -> Core () warnConflict fxName all = @@ -430,6 +433,33 @@ mutual (PLam fc top Explicit (PRef fc (MN "arg" 0)) (PImplicit fc) (POp fc (MkFCVal op.fc $ NoBinder arg) op (PRef fc (MN "arg" 0)))) desugarB side ps (PSearch fc depth) = pure $ Elaborable_Search fc depth + desugarB side ps (PIdricInteger fc value) + = do let vfc = virtualiseFC fc + let literal = Elaborable_Primitive_Value fc (BI value) + let positive = Elaborable_Apply vfc + (Elaborable_Name vfc + (NS typesNS $ UN $ Basic "positiveNumberFromInteger")) + literal + let signed = Elaborable_Apply vfc + (Elaborable_Name vfc + (NS typesNS $ UN $ Basic "SignedValue")) + literal + let cardinality = Elaborable_Apply vfc + (Elaborable_Name vfc + (NS typesNS $ UN $ Basic "cardinalityFromInteger")) + literal + case !fromIntegerName of + Nothing => pure $ Elaborable_Alternative fc FirstSuccess + [positive, signed, cardinality, literal] + Just representationLiteral => + pure $ Elaborable_Alternative fc FirstSuccess + [ positive + , signed + , cardinality + , Elaborable_Apply vfc + (Elaborable_Name vfc representationLiteral) + literal + ] desugarB side ps (PPrimVal fc (BI x)) = case !fromIntegerName of Nothing => @@ -877,10 +907,18 @@ mutual _ => do arg' <- desugarTree side ps (Leaf $ PPrimVal fc c) pure (PApp loc (PRef opFC (UN $ Basic "negate")) arg') + desugarTree side ps (Pre loc opFC (OpSymbols $ UN $ Basic "-~-", _) $ Leaf $ PIdricInteger fc value) + = let newFC = fromMaybe EmptyFC (mergeFC loc fc) + in pure $ PIdricInteger newFC (prim__sub_Integer 0 value) + desugarTree side ps (Pre loc opFC (OpSymbols $ UN $ Basic "-", _) arg) = do arg' <- desugarTree side ps arg pure (PApp loc (PRef opFC (UN $ Basic "negate")) arg') + desugarTree side ps (Pre loc opFC (OpSymbols $ UN $ Basic "-~-", _) arg) + = do arg' <- desugarTree side ps arg + pure (PApp loc (PRef opFC (UN $ Basic "idricNegate")) arg') + desugarTree side ps (Pre loc opFC (op, _) arg) = do arg' <- desugarTree side ps arg pure (PApp loc (PRef opFC op.toName) arg') diff --git a/Idris/Parser.idr b/Idris/Parser.idr index c6b3d857c0..b228eb71eb 100644 --- a/Idris/Parser.idr +++ b/Idris/Parser.idr @@ -125,6 +125,11 @@ atom fname pure (PType (boundToFC fname x)) <|> do x <- bounds $ name pure (PRef (boundToFC fname x) x.val) + <|> the (Rule PTerm) + (do x <- bounds idricIntegerLit + let fc = boundToFC fname x + actD (decorationFromBounded fname Data x) + pure (PIdricInteger {nm = Name} fc x.val)) <|> do x <- bounds $ dependentDecorate fname constant $ \c => if isPrimType c then Typ diff --git a/Idris/Pretty.idr b/Idris/Pretty.idr index d3a4d9b2a9..8ac3e3ddcd 100644 --- a/Idris/Pretty.idr +++ b/Idris/Pretty.idr @@ -347,6 +347,7 @@ mutual prettyPrec d (PUnquote _ tm) = parenthesise (d > startPrec) $ "~" <+> parens (pretty tm) prettyPrec d (PRunElab _ tm) = parenthesise (d > startPrec) $ pragma "%runElab" <++> pretty tm prettyPrec d (PPrimVal _ c) = pretty c + prettyPrec d (PIdricInteger _ value) = byShow value prettyPrec d (PHole _ _ n) = hole (pretty0 (strCons '?' n)) prettyPrec d (PType _) = annotate (TCon Nothing) "Type" prettyPrec d (PAs _ _ n p) = pretty0 n <+> "@" <+> prettyPrec d p diff --git a/Idris/Syntax.idr b/Idris/Syntax.idr index 0ac3a8c63c..4d6c50b2e5 100644 --- a/Idris/Syntax.idr +++ b/Idris/Syntax.idr @@ -111,6 +111,7 @@ mutual PSearch : FC -> (depth : Nat) -> PTerm' nm PPrimVal : FC -> Constant -> PTerm' nm + PIdricInteger : FC -> Integer -> PTerm' nm PQuote : FC -> PTerm' nm -> PTerm' nm PQuoteName : FC -> Name -> PTerm' nm PQuoteDecl : FC -> List (PDecl' nm) -> PTerm' nm @@ -184,6 +185,7 @@ mutual getPTermLoc (PForce fc _) = fc getPTermLoc (PSearch fc _) = fc getPTermLoc (PPrimVal fc _) = fc + getPTermLoc (PIdricInteger fc _) = fc getPTermLoc (PQuote fc _) = fc getPTermLoc (PQuoteName fc _) = fc getPTermLoc (PQuoteDecl fc _) = fc @@ -911,6 +913,7 @@ parameters {0 nm : Type} (toName : nm -> Name) showPTermPrec d (PUnquote _ tm) = "~(" ++ showPTermPrec d tm ++ ")" showPTermPrec d (PRunElab _ tm) = "%runElab " ++ showPTermPrec d tm showPTermPrec d (PPrimVal _ c) = showPrec d c + showPTermPrec d (PIdricInteger _ value) = show value showPTermPrec _ (PHole _ _ n) = "?" ++ n showPTermPrec _ (PType _) = "Type" showPTermPrec d (PAs _ _ n p) = showPrec d n ++ "@" ++ showPTermPrec d p @@ -1107,6 +1110,7 @@ initSyntax initFixities : ANameMap FixityInfo initFixities = fromList [ (UN $ Basic "-", MkFixityInfo EmptyFC Export NotBinding Prefix 10) + , (UN $ Basic "-~-", MkFixityInfo EmptyFC Export NotBinding Prefix 10) , (UN $ Basic "negate", MkFixityInfo EmptyFC Export NotBinding Prefix 10) -- for documentation purposes , (UN $ Basic "=", MkFixityInfo EmptyFC Export NotBinding Infix 0) ] @@ -1204,4 +1208,3 @@ Show PDeclNoFC where show (PRunElabDecl {}) = "PRunElabDecl" show (PDirective {}) = "PDirective" show (PBuiltin {}) = "PBuiltin" - diff --git a/Idris/Syntax/Traversals.idr b/Idris/Syntax/Traversals.idr index 94192a11c8..cef993b31e 100644 --- a/Idris/Syntax/Traversals.idr +++ b/Idris/Syntax/Traversals.idr @@ -77,6 +77,7 @@ mapPTermM f = goPTerm where >>= f goPTerm t@(PSearch {}) = f t goPTerm t@(PPrimVal {}) = f t + goPTerm t@(PIdricInteger {}) = f t goPTerm (PQuote fc x) = PQuote fc <$> goPTerm x >>= f @@ -439,6 +440,7 @@ mapPTerm f = goPTerm where = f $ PForce fc $ goPTerm x goPTerm t@(PSearch {}) = f t goPTerm t@(PPrimVal {}) = f t + goPTerm t@(PIdricInteger {}) = f t goPTerm (PQuote fc x) = f $ PQuote fc $ goPTerm x goPTerm t@(PQuoteName {}) = f t @@ -635,6 +637,7 @@ substFC fc = mapPTerm $ \case PForce _ x => PForce fc x PSearch _ depth => PSearch fc depth PPrimVal _ x => PPrimVal fc x + PIdricInteger _ value => PIdricInteger fc value PQuote _ x => PQuote fc x PQuoteName _ n => PQuoteName fc n PQuoteDecl _ xs => PQuoteDecl fc xs diff --git a/Parser/Lexer/Source.idr b/Parser/Lexer/Source.idr index 525f53c03c..2def7610fa 100644 --- a/Parser/Lexer/Source.idr +++ b/Parser/Lexer/Source.idr @@ -26,7 +26,7 @@ public export data SourceSyntax = IdrisSyntax | IdricSyntax isIdricSyntaxSymbol : Char -> Bool -isIdricSyntaxSymbol c = c `elem` unpack "→⇒←≤" +isIdricSyntaxSymbol c = c `elem` unpack "→⇒←≤−" public export data DebugInfo @@ -49,6 +49,7 @@ data Token = CharLit String | DoubleLit Double | IntegerLit Integer + | IdricIntegerLit Integer -- String | StringBegin Nat IsMultiline -- The escape depth and whether is multiline string | StringEnd @@ -87,6 +88,7 @@ Show Token where show (CharLit x) = "character " ++ show x show (DoubleLit x) = "double " ++ show x show (IntegerLit x) = "literal " ++ show x + show (IdricIntegerLit x) = "Idriç literal " ++ show x -- String show (StringBegin hashtag Single) = "string begin" show (StringBegin hashtag Multi) = "multiline string begin" @@ -119,6 +121,7 @@ Pretty Void Token where pretty (CharLit x) = pretty "character" <++> squotes (pretty x) pretty (DoubleLit x) = pretty "double" <++> pretty (show x) pretty (IntegerLit x) = pretty "literal" <++> pretty (show x) + pretty (IdricIntegerLit x) = pretty "Idriç literal" <++> pretty (show x) -- String pretty (StringBegin hashtag Single) = reflow "string begin" pretty (StringBegin hashtag Multi) = reflow "multiline string begin" diff --git a/Parser/Rule/Source.idr b/Parser/Rule/Source.idr index 1708debeef..93eb173b26 100644 --- a/Parser/Rule/Source.idr +++ b/Parser/Rule/Source.idr @@ -126,6 +126,15 @@ intLit = terminal "Expected integer literal" $ \case IntegerLit i => Just i + IdricIntegerLit i => Just i + _ => Nothing + +export +idricIntegerLit : Rule Integer +idricIntegerLit + = terminal "Expected Idriç integer literal" $ + \case + IdricIntegerLit i => Just i _ => Nothing export diff --git a/Parser/Source.idr b/Parser/Source.idr index 3d51eafe67..79dd1a6b5b 100644 --- a/Parser/Source.idr +++ b/Parser/Source.idr @@ -30,9 +30,12 @@ canonicalize_idric_namespace ns canonicalize_idric_token : Token -> Token canonicalize_idric_token (Ident "choice") = Keyword "choice" -canonicalize_idric_token (Ident "Number") = Ident "Nat" +canonicalize_idric_token (IntegerLit value) = IdricIntegerLit value +canonicalize_idric_token (Symbol "+") = Symbol "+~+" +canonicalize_idric_token (Symbol "*") = Symbol "*~*" +canonicalize_idric_token (Symbol "-") = Symbol "-~-" +canonicalize_idric_token (Symbol "−") = Symbol "-~-" canonicalize_idric_token (Ident "Text") = Ident "String" -canonicalize_idric_token (Ident "ℕ") = Ident "Nat" canonicalize_idric_token (DotSepIdent ns "Text") = if unsafeUnfoldNamespace ns == ["Data"] then DotSepIdent ns "String" diff --git a/STYLE.md b/STYLE.md index 38c3775398..3b0549c399 100644 --- a/STYLE.md +++ b/STYLE.md @@ -24,10 +24,12 @@ able to re-export; it is not a ceremonial prefix for every definition. - Use `snake_case` for names under our control and prefer complete domain words to conventional Haskell abbreviations. -- Use `Number`, not `Nat` or the older migration spelling `ℕ`, in new `.idric` - source. Use `Text`, not `String`, for decoded character text, and import - `Data.Text` for inherited text operations. These spellings lower to inherited - representations inside the bootstrap compiler. +- Use `Number` for ordinary positive whole numbers beginning at one, and + `±Number` for ordinary signed whole numbers, including zero. Do not use + `Nat`, `Natural`, `Int`, `Integer`, or the retired migration spelling `ℕ` as + programmer-facing synonyms for these Idriç types. Use `Text`, not `String`, + for decoded character text, and import `Data.Text` for inherited text + operations. Bootstrap and representation code may retain its native names. - Use a semantic type instead of `Number`, `Text`, a raw integer, `Bits8`, or a flag when the value has narrower operations or invariants. - Use `List` for an ordinary sequence, `SizedList` or `ListOfLength` when length @@ -40,9 +42,14 @@ able to re-export; it is not a ceremonial prefix for every definition. - Avoid gratuitous currying, bare-application chains, constructor-led program descriptions, and implementation types in domain vocabulary. -The general name for a number that may be positive or negative is still -unresolved. Prefer a domain name where there is one and do not introduce a new -unrestricted wrapper merely to avoid inherited spelling. +`Number` excludes zero. `±Number` admits negative values, zero, and positive +values, and positive `Number` values widen to it when an operation requires +the broader type. Subtracting one `Number` from another therefore produces a +`±Number`; addition and multiplication preserve `Number`. Use `Cardinality` +for a zero-capable count, length, rank, or size when that is the value's actual +meaning. Prefer a still more specific domain type when its operations or +invariants differ. Do not add `Positive Number` as a verbose synonym or a +fundamental `Negative Number` merely for symmetry. ## Semantic boundaries diff --git a/_/BRANCHES.md b/_/BRANCHES.md index 254c73f860..d6600cd18d 100644 --- a/_/BRANCHES.md +++ b/_/BRANCHES.md @@ -1,6 +1,6 @@ # Idriç branch map -This map records the branch topology as of 2026-08-27. It exists to prevent an +This map records the branch topology as of 2026-09-08. It exists to prevent an old Idris bootstrap, a backend experiment, or a closed pull-request branch from being mistaken for the current compiler. @@ -28,9 +28,9 @@ These are reviewable changes based on `Idriç`, not alternate compiler roots. | --- | --- | --- | | #6 | `float32-primitive` | Add the 32-bit floating-point primitive | | #10 | `termux-armv7-binary` | Build the compiler for 32-bit ARMv7 Termux | -| #11 | `fix-idric-natural-vocabulary` | Use `ℕ` at the Idriç source boundary | | #13 | `depends-on-syntax` | Restrict `depends on` to dependency declarations | | #19 | `prelude/descriptive-io-names` | Make descriptive I/O names primary | +| #77 | `style/idric-number-text-surface` | Define the active Idriç `Number`, `±Number`, `Text`, and `Data.Text` surface | Preserve these names while their pull requests are open. Delete each head branch after the change is merged or deliberately abandoned. diff --git a/_/EDRIC.md b/_/EDRIC.md index d5e0c7e44c..cb62cde004 100644 --- a/_/EDRIC.md +++ b/_/EDRIC.md @@ -24,22 +24,30 @@ The first Edric-specific syntax is the storage-neutral `choice` declaration desc ## Number and text vocabulary -Idriç source spells the unrestricted nonnegative whole-number type `Number` and -decoded character text `Text`. In a `.idric` file the frontend lowers those -names to the inherited Idris 2 bootstrap representations. Ordinary `.idr` -source remains unchanged. The inherited names are implementation and -compatibility spellings, not names for new Idriç APIs, examples, or teaching -material. +Idriç source spells ordinary positive whole numbers `Number` and ordinary +signed whole numbers `±Number`. `Number` begins at one and excludes zero; +`±Number` includes negative values, zero, and positive values. The latter is +valid source notation in a type position. Ordinary `.idr` source remains +unchanged. Inherited numeric names remain available to compiler, bootstrap, +ABI, and explicit compatibility code, but are not names for new Idriç APIs, +examples, or teaching material. + +Idriç literals are checked against their intended type. Positive literals may +inhabit `Number`, while zero and negative literals cannot. All three kinds may +inhabit `±Number`, and a `Number` can be widened with `numberAsSigned` when an +explicit conversion is useful. Addition and multiplication of `Number` +values remain positive; subtraction returns `±Number`. `Cardinality` names a +zero-capable count, length, rank, or size. These are distinct source meanings +even though the bootstrap uses inherited arbitrary-precision representations. Fresh `.idric` source imports `Data.Text` when it needs the inherited text operations. The frontend lowers that exact module boundary to `Data.String`; ordinary `.idr` module names remain unchanged. -`Number` and `Text` describe general language values. Code should still use a -more specific semantic type—source location, byte count, path, protocol field, -and so on—when operations or invariants differ. The older `ℕ` input spelling is -accepted temporarily so existing Idriç source can migrate without a flag day; -it is not the current spelling for new source. +`Number`, `±Number`, and `Text` describe general language values. Code should +still use a more specific semantic type—source location, byte count, path, +protocol field, and so on—when operations or invariants differ. The older `ℕ` +input spelling is retired rather than retained as a competing alias. ## Data-structure vocabulary @@ -67,9 +75,9 @@ snake_case names: ```idris choice existing_touch_target one_of - fixed_value Number - zero Number - pole Number + fixed_value ±Number + zero ±Number + pole ±Number choice touch_beginning one_of near_existing existing_touch_target @@ -220,11 +228,16 @@ A new thread working on Edric should: - Idriç source extension: `.idric`; `.idr` remains accepted for Idris compatibility. - Storage-neutral, lower snake_case `choice ... one_of` syntax: implemented for `.idric` only. - Ordinary `.idr` use of `choice` and `one_of` as identifiers: preserved and regression-tested. -- Idriç source spells nonnegative whole numbers `Number` and decoded character - text `Text`; the frontend lowers both to inherited bootstrap representations. +- Idriç source spells positive whole numbers `Number`, signed whole numbers + `±Number`, and decoded character text `Text`. `Number` excludes zero; + `±Number` admits negative values, zero, and positive values. +- Source literals and arithmetic enforce that distinction. `Number - Number` + returns `±Number`, while positive values may be widened deliberately. +- Zero-capable counts, lengths, ranks, and sizes use `Cardinality` or a more + specific domain type rather than being mislabeled as signed values. - Idriç source spells the inherited text-operation module `Data.Text`; the frontend lowers that exact module boundary to `Data.String`. -- The older `ℕ` spelling remains a migration alias, not the current spelling. +- The older `ℕ` spelling is retired at the Idriç source boundary. - Idriç source accepts `→`, `⇒`, `←`, and `≤` as compact aliases for `->`, `=>`, `<-`, and `<=`; the ASCII spellings remain accepted. - The aliases are filename-scoped to `.idric`; ordinary `.idr` Unicode identifiers remain unchanged. - Canonical Unicode pretty-printing is not yet claimed by this input-syntax slice. diff --git a/_/edric b/_/edric index 26dcee1b3a..2564b4a502 100755 --- a/_/edric +++ b/_/edric @@ -53,6 +53,7 @@ smoke_test() { run_test idris2/basic/edric005 run_test idris2/basic/edric006 run_test idris2/basic/edric009 + run_test idris2/basic/edric010 sh "$repo_root/scripts/test-one-step-emitter.sh" } diff --git a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric index d2f412c48b..841bd936ea 100644 --- a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric +++ b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric @@ -10,7 +10,7 @@ import MathematicalSpaces public export data EuclideanStructure : FiniteSpace → Type where StandardCoordinate : - {rank : Number} → + {rank : CoordinateRank} → {name : SpaceName rank} → EuclideanStructure (NamedFiniteSpace name) @@ -47,19 +47,19 @@ public export dot : {space : FiniteSpace} → EuclideanStructure space → - ExactVectorSample space → ExactVectorSample space → Integer + ExactVectorSample space → ExactVectorSample space → ±Number dot structure left right = contract (lower_index structure left) right public export squared_norm : {space : FiniteSpace} → - EuclideanStructure space → ExactVectorSample space → Integer + EuclideanStructure space → ExactVectorSample space → ±Number squared_norm structure value = dot structure value value -- SquareRoot is deliberately symbolic. The exact integer radicand remains -- visible, and this small semantic layer makes no floating-point choice. public export -data ExactSquareRoot = SquareRoot Integer +data ExactSquareRoot = SquareRoot ±Number public export norm : @@ -71,7 +71,7 @@ public export squared_distance : {space : FiniteSpace} → EuclideanStructure space → - ExactVectorSample space → ExactVectorSample space → Integer + ExactVectorSample space → ExactVectorSample space → ±Number squared_distance structure left right = squared_norm structure (difference_vector left right) @@ -107,7 +107,7 @@ raise_indexed structure (LowerIndex value) = -- -------------------------------------------------------------------------- public export -data Quaternion = Q Integer Integer Integer Integer +data Quaternion = Q ±Number ±Number ±Number ±Number public export quaternion_negate : Quaternion → Quaternion @@ -127,7 +127,7 @@ quaternion_multiply (Q a b c d) (Q e f g h) = (a * h + b * g - c * f + d * e) public export -quaternion_norm_squared : Quaternion → Integer +quaternion_norm_squared : Quaternion → ±Number quaternion_norm_squared (Q a b c d) = a * a + b * b + c * c + d * d @@ -151,7 +151,7 @@ public export data UnitQuaternion : Type where UnitQuaternionValue : (value : Quaternion) → - quaternion_norm_squared value = 1 → + quaternion_norm_squared value = the ±Number 1 → UnitQuaternion public export @@ -200,14 +200,14 @@ data OrthogonalTransform : {structure : EuclideanStructure space} → OrthogonalTransform structure Preserving FirstAxisReflectionTransform : - {n : Number} → + {n : CoordinateRank} → {name : SpaceName (S n)} → OrthogonalTransform {space = NamedFiniteSpace name} StandardCoordinate Reversing FirstPlaneQuarterTurnTransform : - {n : Number} → + {n : CoordinateRank} → {name : SpaceName (S (S n))} → OrthogonalTransform {space = NamedFiniteSpace name} @@ -236,7 +236,7 @@ data SpecialOrthogonal : public export first_axis_reflection : - {n : Number} → + {n : CoordinateRank} → {name : SpaceName (S n)} → (structure : EuclideanStructure (NamedFiniteSpace name)) → OrthogonalTransform structure Reversing @@ -244,7 +244,7 @@ first_axis_reflection StandardCoordinate = FirstAxisReflectionTransform public export first_plane_quarter_turn : - {n : Number} → + {n : CoordinateRank} → {name : SpaceName (S (S n))} → (structure : EuclideanStructure (NamedFiniteSpace name)) → SpecialOrthogonal structure @@ -354,7 +354,7 @@ apply_special_orthogonal_exact (InSO transform) vector = -- the connected OrthogonalTransform evaluator. public export apply_first_axis_reflection : - {n : Number} → + {n : CoordinateRank} → {name : SpaceName (S n)} → (structure : EuclideanStructure (NamedFiniteSpace name)) → ExactVectorSample (NamedFiniteSpace name) → @@ -364,7 +364,7 @@ apply_first_axis_reflection structure = public export apply_first_plane_quarter_turn : - {n : Number} → + {n : CoordinateRank} → {name : SpaceName (S (S n))} → (structure : EuclideanStructure (NamedFiniteSpace name)) → ExactVectorSample (NamedFiniteSpace name) → diff --git a/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md b/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md index 93c5cdfd8c..09f847d038 100644 --- a/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md +++ b/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md @@ -85,8 +85,8 @@ real bootstrapped Idric path it: 3. executes that program and compares its PASS lines with `expected`. The focused source uses `ExactVectorSample` and `ExactCovectorSample`, making -their `Integer` coordinate fragment explicit in the type names. These values -denote exact samples inside the named real coordinate space; they do not define +their exact `±Number` coordinate fragment explicit in the type names. These +values denote exact samples inside the named real coordinate space; they do not define its complete scalar carrier. The `Refl` declarations check the stated images, squared norms, dot products, involution, fourth-power identity, and the preserved 128th coordinate by compiler normalization. diff --git a/_/examples/unified-higher-mathematics/MathematicalSpaces.idric b/_/examples/unified-higher-mathematics/MathematicalSpaces.idric index c885845fce..3e0ef0fb33 100644 --- a/_/examples/unified-higher-mathematics/MathematicalSpaces.idric +++ b/_/examples/unified-higher-mathematics/MathematicalSpaces.idric @@ -8,7 +8,11 @@ module MathematicalSpaces -- Rank equality alone is still not space equality. public export -data SpaceName : Number → Type where +CoordinateRank : Type +CoordinateRank = Cardinality + +public export +data SpaceName : CoordinateRank → Type where PlaneName : SpaceName 2 ImagePlaneName : SpaceName 2 RealThreeName : SpaceName 3 @@ -16,10 +20,10 @@ data SpaceName : Number → Type where public export data FiniteSpace : Type where - NamedFiniteSpace : {rank : Number} → SpaceName rank → FiniteSpace + NamedFiniteSpace : {rank : CoordinateRank} → SpaceName rank → FiniteSpace public export -space_rank : FiniteSpace → Number +space_rank : FiniteSpace → CoordinateRank space_rank (NamedFiniteSpace {rank} _) = rank public export @@ -42,11 +46,11 @@ public export real128_space : FiniteSpace real128_space = NamedFiniteSpace Real128Name --- Integer coordinates are exact executable samples of the named real +-- ±Number coordinates are exact executable samples of the named real -- coordinate spaces. ExactVectorSample and ExactCovectorSample below -- represent only this sample language; they are not definitions of the -- complete real scalar field or of every vector in the ambient space. This --- preserves the R^128 oracle without pretending Integer is the field of reals. +-- preserves the R^128 oracle without pretending ±Number is the field of reals. -- UNSAFE REPRESENTATION BOUNDARY. The raw coordinates, their constructors, -- and every operation that exposes or rebuilds them are deliberately named @@ -57,20 +61,20 @@ real128_space = NamedFiniteSpace Real128Name -- never performs such a conversion implicitly. public export -data RawExactCoordinates : Number → Type where +data RawExactCoordinates : CoordinateRank → Type where UnsafeCoordinateNil : RawExactCoordinates Z UnsafeCoordinateCons : - {n : Number} → - Integer → RawExactCoordinates n → RawExactCoordinates (S n) + {n : CoordinateRank} → + ±Number → RawExactCoordinates n → RawExactCoordinates (S n) public export -unsafe_zero_coordinates : (n : Number) → RawExactCoordinates n +unsafe_zero_coordinates : (n : CoordinateRank) → RawExactCoordinates n unsafe_zero_coordinates Z = UnsafeCoordinateNil unsafe_zero_coordinates (S n) = UnsafeCoordinateCons 0 (unsafe_zero_coordinates n) public export unsafe_add_coordinates : - {n : Number} → + {n : CoordinateRank} → RawExactCoordinates n → RawExactCoordinates n → RawExactCoordinates n unsafe_add_coordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil unsafe_add_coordinates @@ -81,14 +85,14 @@ unsafe_add_coordinates (unsafe_add_coordinates left_rest right_rest) public export -unsafe_negate_coordinates : {n : Number} → RawExactCoordinates n → RawExactCoordinates n +unsafe_negate_coordinates : {n : CoordinateRank} → RawExactCoordinates n → RawExactCoordinates n unsafe_negate_coordinates UnsafeCoordinateNil = UnsafeCoordinateNil unsafe_negate_coordinates (UnsafeCoordinateCons value rest) = UnsafeCoordinateCons (-value) (unsafe_negate_coordinates rest) public export unsafe_subtract_coordinates : - {n : Number} → + {n : CoordinateRank} → RawExactCoordinates n → RawExactCoordinates n → RawExactCoordinates n unsafe_subtract_coordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil unsafe_subtract_coordinates @@ -100,7 +104,7 @@ unsafe_subtract_coordinates public export unsafe_scale_coordinates : - {n : Number} → Integer → RawExactCoordinates n → RawExactCoordinates n + {n : CoordinateRank} → ±Number → RawExactCoordinates n → RawExactCoordinates n unsafe_scale_coordinates scalar UnsafeCoordinateNil = UnsafeCoordinateNil unsafe_scale_coordinates scalar (UnsafeCoordinateCons value rest) = UnsafeCoordinateCons @@ -112,8 +116,8 @@ unsafe_scale_coordinates scalar (UnsafeCoordinateCons value rest) = -- the checked vector/covector API; `dot` is the metric-requiring operation. public export unsafe_pair_coordinates : - {n : Number} → - RawExactCoordinates n → RawExactCoordinates n → Integer + {n : CoordinateRank} → + RawExactCoordinates n → RawExactCoordinates n → ±Number unsafe_pair_coordinates UnsafeCoordinateNil UnsafeCoordinateNil = 0 unsafe_pair_coordinates (UnsafeCoordinateCons left left_rest) @@ -126,7 +130,7 @@ unsafe_pair_coordinates public export data ExactVectorSample : FiniteSpace → Type where UnsafeVectorCoordinates : - {rank : Number} → + {rank : CoordinateRank} → {name : SpaceName rank} → RawExactCoordinates rank → ExactVectorSample (NamedFiniteSpace name) @@ -134,7 +138,7 @@ data ExactVectorSample : FiniteSpace → Type where public export data ExactCovectorSample : FiniteSpace → Type where UnsafeCovectorCoordinates : - {rank : Number} → + {rank : CoordinateRank} → {name : SpaceName rank} → RawExactCoordinates rank → ExactCovectorSample (NamedFiniteSpace name) @@ -186,7 +190,7 @@ difference_vector public export scale_vector : {space : FiniteSpace} → - Integer → ExactVectorSample space → ExactVectorSample space + ±Number → ExactVectorSample space → ExactVectorSample space scale_vector scalar (UnsafeVectorCoordinates coordinates) = UnsafeVectorCoordinates (unsafe_scale_coordinates scalar coordinates) @@ -211,7 +215,7 @@ negate_covector (UnsafeCovectorCoordinates coordinates) = public export scale_covector : {space : FiniteSpace} → - Integer → ExactCovectorSample space → ExactCovectorSample space + ±Number → ExactCovectorSample space → ExactCovectorSample space scale_covector scalar (UnsafeCovectorCoordinates coordinates) = UnsafeCovectorCoordinates (unsafe_scale_coordinates scalar coordinates) @@ -223,7 +227,7 @@ scale_covector scalar (UnsafeCovectorCoordinates coordinates) = public export contract : {space : FiniteSpace} → - ExactCovectorSample space → ExactVectorSample space → Integer + ExactCovectorSample space → ExactVectorSample space → ±Number contract (UnsafeCovectorCoordinates covector_coordinates) (UnsafeVectorCoordinates vector_coordinates) = @@ -232,31 +236,31 @@ contract -- Small named fixtures used by the focused compiler tests. public export -plane_vector : Integer → Integer → ExactVectorSample plane_space +plane_vector : ±Number → ±Number → ExactVectorSample plane_space plane_vector first second = UnsafeVectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -plane_covector : Integer → Integer → ExactCovectorSample plane_space +plane_covector : ±Number → ±Number → ExactCovectorSample plane_space plane_covector first second = UnsafeCovectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -image_plane_vector : Integer → Integer → ExactVectorSample image_plane_space +image_plane_vector : ±Number → ±Number → ExactVectorSample image_plane_space image_plane_vector first second = UnsafeVectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -image_plane_covector : Integer → Integer → ExactCovectorSample image_plane_space +image_plane_covector : ±Number → ±Number → ExactCovectorSample image_plane_space image_plane_covector first second = UnsafeCovectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -three_vector : Integer → Integer → Integer → ExactVectorSample real_three_space +three_vector : ±Number → ±Number → ±Number → ExactVectorSample real_three_space three_vector first second third = UnsafeVectorCoordinates (UnsafeCoordinateCons first @@ -264,7 +268,7 @@ three_vector first second third = (UnsafeCoordinateCons third UnsafeCoordinateNil))) public export -three_covector : Integer → Integer → Integer → ExactCovectorSample real_three_space +three_covector : ±Number → ±Number → ±Number → ExactCovectorSample real_three_space three_covector first second third = UnsafeCovectorCoordinates (UnsafeCoordinateCons first @@ -290,6 +294,6 @@ data IndexedValue : Variance → FiniteSpace → Type where public export contract_index : {space : FiniteSpace} → - IndexedValue Lower space → IndexedValue Upper space → Integer + IndexedValue Lower space → IndexedValue Upper space → ±Number contract_index (LowerIndex covector) (UpperIndex vector) = contract covector vector diff --git a/_/examples/unified-higher-mathematics/PresheafRestriction.idric b/_/examples/unified-higher-mathematics/PresheafRestriction.idric index eaaf9741aa..3eb8f4a5fd 100644 --- a/_/examples/unified-higher-mathematics/PresheafRestriction.idric +++ b/_/examples/unified-higher-mathematics/PresheafRestriction.idric @@ -18,9 +18,9 @@ data Included : Open → Open → Type where public export data Section : Open → Type where - WholeSection : Integer → Section Whole - PatchSection : Integer → Section Patch - PointSection : Integer → Section Point + WholeSection : ±Number → Section Whole + PatchSection : ±Number → Section Patch + PointSection : ±Number → Section Point public export restrict : {u, v : Open} → Included v u → Section u → Section v diff --git a/_/examples/unified-higher-mathematics/README.md b/_/examples/unified-higher-mathematics/README.md index 77745f92df..10151bb5a3 100644 --- a/_/examples/unified-higher-mathematics/README.md +++ b/_/examples/unified-higher-mathematics/README.md @@ -14,14 +14,14 @@ name is itself indexed by its rank, so `PlaneName` cannot be reused at rank and `image_plane_space` remain different even though both have rank two. `ExactVectorSample space` and `ExactCovectorSample space` are separate -datatypes. They are explicitly the executable integer-coordinate fragment of +datatypes. They are explicitly the executable signed-number-coordinate fragment of the named real coordinate space, not its complete carrier and not a claim that -the field of real scalars is `Integer`. Every represented sample nevertheless +the field of real scalars is `±Number`. Every represented sample nevertheless denotes a genuine vector or covector. The metric-free operation is covector evaluation: ```idris -contract : ExactCovectorSample space → ExactVectorSample space → Integer +contract : ExactCovectorSample space → ExactVectorSample space → ±Number ``` `RawExactCoordinates`, `UnsafeVectorCoordinates`, and the other diff --git a/_/examples/unified-higher-mathematics/Tests.idric b/_/examples/unified-higher-mathematics/Tests.idric index 9c4f011b2a..b781b60caa 100644 --- a/_/examples/unified-higher-mathematics/Tests.idric +++ b/_/examples/unified-higher-mathematics/Tests.idric @@ -17,7 +17,7 @@ import NamedFacts -- -------------------------------------------------------------------------- plane_pairing_test : - contract (plane_covector 5 7) (plane_vector 3 4) = 43 + contract (plane_covector 5 7) (plane_vector 3 4) = the ±Number 43 plane_pairing_test = Refl contraction_linear_in_vector_test : @@ -40,37 +40,37 @@ contraction_respects_vector_scaling_test : contract (plane_covector 5 7) (scale_vector 3 (plane_vector 3 4)) - = 3 * contract (plane_covector 5 7) (plane_vector 3 4) + = the ±Number 3 * contract (plane_covector 5 7) (plane_vector 3 4) contraction_respects_vector_scaling_test = Refl contraction_respects_covector_scaling_test : contract (scale_covector 3 (plane_covector 5 7)) (plane_vector 3 4) - = 3 * contract (plane_covector 5 7) (plane_vector 3 4) + = the ±Number 3 * contract (plane_covector 5 7) (plane_vector 3 4) contraction_respects_covector_scaling_test = Refl failing "Mismatch between: PlaneName and ImagePlaneName." equal_rank_named_spaces_do_not_unify : ExactVectorSample image_plane_space equal_rank_named_spaces_do_not_unify = plane_vector 1 2 -failing "Mismatch between: 0 and 1." +failing "Mismatch between: 0 and S" one_name_cannot_claim_a_different_rank : FiniteSpace one_name_cannot_claim_a_different_rank = NamedFiniteSpace {rank = 3} PlaneName failing "Mismatch between: RealThreeName and PlaneName." - mismatched_dimension_contraction : Integer + mismatched_dimension_contraction : ±Number mismatched_dimension_contraction = contract (plane_covector 1 2) (three_vector 3 4 5) failing "Mismatch between: ImagePlaneName and PlaneName." - equal_rank_mismatched_space_contraction : Integer + equal_rank_mismatched_space_contraction : ±Number equal_rank_mismatched_space_contraction = contract (plane_covector 1 2) (image_plane_vector 3 4) failing "Mismatch between: ExactVectorSample plane_space and ExactCovectorSample" - vector_vector_contraction_without_euclidean_structure : Integer + vector_vector_contraction_without_euclidean_structure : ±Number vector_vector_contraction_without_euclidean_structure = contract (plane_vector 1 2) (plane_vector 3 4) @@ -87,11 +87,11 @@ metric_raises_covector_test : metric_raises_covector_test = Refl metric_dot_test : - dot plane_euclidean (plane_vector 3 4) (plane_vector 5 7) = 43 + dot plane_euclidean (plane_vector 3 4) (plane_vector 5 7) = the ±Number 43 metric_dot_test = Refl metric_squared_norm_test : - squared_norm plane_euclidean (plane_vector 3 4) = 25 + squared_norm plane_euclidean (plane_vector 3 4) = the ±Number 25 metric_squared_norm_test = Refl metric_norm_test : @@ -102,7 +102,7 @@ metric_squared_distance_test : squared_distance plane_euclidean (plane_vector 5 7) - (plane_vector 2 3) = 25 + (plane_vector 2 3) = the ±Number 25 metric_squared_distance_test = Refl metric_distance_test : @@ -119,18 +119,18 @@ metric_distance_test = Refl named_index_contraction_test : contract_index (LowerIndex (plane_covector 5 7)) - (UpperIndex (plane_vector 3 4)) = 43 + (UpperIndex (plane_vector 3 4)) = the ±Number 43 named_index_contraction_test = Refl failing "Mismatch between: Lower and Upper." - same_variance_index_contraction : Integer + same_variance_index_contraction : ±Number same_variance_index_contraction = contract_index (LowerIndex (plane_covector 5 7)) (LowerIndex (plane_covector 3 4)) failing "Mismatch between: ImagePlaneName and PlaneName." - equal_rank_named_index_space_mismatch : Integer + equal_rank_named_index_space_mismatch : ±Number equal_rank_named_index_space_mismatch = contract_index (LowerIndex (plane_covector 5 7)) @@ -139,7 +139,7 @@ failing "Mismatch between: ImagePlaneName and PlaneName." metric_driven_index_lowering_test : contract_index (lower_indexed plane_euclidean (UpperIndex (plane_vector 5 7))) - (UpperIndex (plane_vector 3 4)) = 43 + (UpperIndex (plane_vector 3 4)) = the ±Number 43 metric_driven_index_lowering_test = Refl metric_driven_index_raising_test : @@ -160,7 +160,7 @@ metric_driven_index_raising_test = Refl -- state all 128 coordinates; semantic clients use the named constructors and -- checked contraction/metric operations above. -last_coordinate : (n : Number) → Integer → RawExactCoordinates (S n) +last_coordinate : (n : CoordinateRank) → ±Number → RawExactCoordinates (S n) last_coordinate Z value = UnsafeCoordinateCons value UnsafeCoordinateNil last_coordinate (S n) value = UnsafeCoordinateCons 0 (last_coordinate n value) @@ -233,27 +233,27 @@ r128_quarter_turn_exact_image_test = Refl r128_reflection_preserves_squared_norm_test : squared_norm real128_euclidean - (apply_first_axis_reflection real128_euclidean r128_sample) = 250 + (apply_first_axis_reflection real128_euclidean r128_sample) = the ±Number 250 r128_reflection_preserves_squared_norm_test = Refl r128_quarter_turn_preserves_squared_norm_test : squared_norm real128_euclidean - (apply_first_plane_quarter_turn real128_euclidean r128_sample) = 250 + (apply_first_plane_quarter_turn real128_euclidean r128_sample) = the ±Number 250 r128_quarter_turn_preserves_squared_norm_test = Refl r128_reflection_preserves_dot_test : dot real128_euclidean (apply_first_axis_reflection real128_euclidean r128_sample) - (apply_first_axis_reflection real128_euclidean r128_companion) = 190 + (apply_first_axis_reflection real128_euclidean r128_companion) = the ±Number 190 r128_reflection_preserves_dot_test = Refl r128_quarter_turn_preserves_dot_test : dot real128_euclidean (apply_first_plane_quarter_turn real128_euclidean r128_sample) - (apply_first_plane_quarter_turn real128_euclidean r128_companion) = 190 + (apply_first_plane_quarter_turn real128_euclidean r128_companion) = the ±Number 190 r128_quarter_turn_preserves_dot_test = Refl r128_reflection_is_involution_test : @@ -270,7 +270,7 @@ r128_four_quarter_turns_are_identity_test : = r128_sample r128_four_quarter_turns_are_identity_test = Refl -last_coordinate_value : {n : Number} → RawExactCoordinates (S n) → Integer +last_coordinate_value : {n : CoordinateRank} → RawExactCoordinates (S n) → ±Number last_coordinate_value (UnsafeCoordinateCons value UnsafeCoordinateNil) = value last_coordinate_value (UnsafeCoordinateCons _ rest@(UnsafeCoordinateCons _ _)) = last_coordinate_value rest @@ -278,13 +278,13 @@ last_coordinate_value r128_reflection_preserves_coordinate_128_test : last_coordinate_value (unsafe_coordinates_of_vector - (apply_first_axis_reflection real128_euclidean r128_sample)) = 9 + (apply_first_axis_reflection real128_euclidean r128_sample)) = the ±Number 9 r128_reflection_preserves_coordinate_128_test = Refl r128_quarter_turn_preserves_coordinate_128_test : last_coordinate_value (unsafe_coordinates_of_vector - (apply_first_plane_quarter_turn real128_euclidean r128_sample)) = 9 + (apply_first_plane_quarter_turn real128_euclidean r128_sample)) = the ±Number 9 r128_quarter_turn_preserves_coordinate_128_test = Refl -- -------------------------------------------------------------------------- @@ -294,22 +294,22 @@ r128_quarter_turn_preserves_coordinate_128_test = Refl north_pole_is_s2_test : UnitSpherePoint real_three_euclidean north_pole_is_s2_test = north_pole_s2 -sphere_s0_h0_rank_test : sphere_integral_cohomology_rank 0 0 = 2 +sphere_s0_h0_rank_test : sphere_integral_cohomology_rank 0 0 = the Cardinality 2 sphere_s0_h0_rank_test = Refl -sphere_s2_h0_rank_test : sphere_integral_cohomology_rank 2 0 = 1 +sphere_s2_h0_rank_test : sphere_integral_cohomology_rank 2 0 = the Cardinality 1 sphere_s2_h0_rank_test = Refl -sphere_s2_h1_rank_test : sphere_integral_cohomology_rank 2 1 = 0 +sphere_s2_h1_rank_test : sphere_integral_cohomology_rank 2 1 = the Cardinality 0 sphere_s2_h1_rank_test = Refl -sphere_s2_h2_rank_test : sphere_integral_cohomology_rank 2 2 = 1 +sphere_s2_h2_rank_test : sphere_integral_cohomology_rank 2 2 = the Cardinality 1 sphere_s2_h2_rank_test = Refl -odd_sphere_euler_test : sphere_euler_characteristic 3 = 0 +odd_sphere_euler_test : sphere_euler_characteristic 3 = the ±Number 0 odd_sphere_euler_test = Refl -even_sphere_euler_test : sphere_euler_characteristic 4 = 2 +even_sphere_euler_test : sphere_euler_characteristic 4 = the ±Number 2 even_sphere_euler_test = Refl quaternion_i_j_test : quaternion_multiply quaternion_i quaternion_j = quaternion_k @@ -319,7 +319,7 @@ quaternion_j_i_test : quaternion_multiply quaternion_j quaternion_i = quaternion_negate quaternion_k quaternion_j_i_test = Refl -quaternion_i_norm_test : quaternion_norm_squared quaternion_i = 1 +quaternion_i_norm_test : quaternion_norm_squared quaternion_i = the ±Number 1 quaternion_i_norm_test = Refl unit_quaternion_rotation_is_so3_test : SpecialOrthogonal real_three_euclidean @@ -331,29 +331,30 @@ unit_quaternion_rotation_action_test : (three_vector 0 1 0) = three_vector 0 (-1) 0 unit_quaternion_rotation_action_test = Refl -cp3_real_dimension_test : cp_real_dimension 3 = 6 +cp3_real_dimension_test : cp_real_dimension 3 = the Cardinality 6 cp3_real_dimension_test = Refl -cp3_hopf_sphere_dimension_test : cp_hopf_sphere_dimension 3 = 7 +cp3_hopf_sphere_dimension_test : cp_hopf_sphere_dimension 3 = the Cardinality 7 cp3_hopf_sphere_dimension_test = Refl -cp2_h0_rank_test : cp_integral_cohomology_rank 2 0 = 1 +cp2_h0_rank_test : cp_integral_cohomology_rank 2 0 = the Cardinality 1 cp2_h0_rank_test = Refl -cp2_h2_rank_test : cp_integral_cohomology_rank 2 2 = 1 +cp2_h2_rank_test : cp_integral_cohomology_rank 2 2 = the Cardinality 1 cp2_h2_rank_test = Refl -cp2_h4_rank_test : cp_integral_cohomology_rank 2 4 = 1 +cp2_h4_rank_test : cp_integral_cohomology_rank 2 4 = the Cardinality 1 cp2_h4_rank_test = Refl -cp2_h3_rank_test : cp_integral_cohomology_rank 2 3 = 0 +cp2_h3_rank_test : cp_integral_cohomology_rank 2 3 = the Cardinality 0 cp2_h3_rank_test = Refl -cp2_h6_rank_test : cp_integral_cohomology_rank 2 6 = 0 +cp2_h6_rank_test : cp_integral_cohomology_rank 2 6 = the Cardinality 0 cp2_h6_rank_test = Refl r3_one_point_compactifies_to_s3_test : - compactified_sphere_dimension (euclidean_one_point_compactification 3) = 3 + compactified_sphere_dimension (euclidean_one_point_compactification 3) = + the Cardinality 3 r3_one_point_compactifies_to_s3_test = Refl -- -------------------------------------------------------------------------- @@ -402,7 +403,7 @@ failing "Mismatch between: ExactVectorSample plane_space and EmbeddedCircleInS2. lookup_named_fact jordan_separation_fact unrelated_context jordan_lookup_conclusion_test : - complement_component_count (fact_conclusion jordan_lookup_test) = 2 + complement_component_count (fact_conclusion jordan_lookup_test) = the Number 2 jordan_lookup_conclusion_test = Refl jordan_lookup_explanation_test : diff --git a/_/examples/unified-higher-mathematics/TopologyFacts.idric b/_/examples/unified-higher-mathematics/TopologyFacts.idric index c7d4d0e1d6..ef722ba880 100644 --- a/_/examples/unified-higher-mathematics/TopologyFacts.idric +++ b/_/examples/unified-higher-mathematics/TopologyFacts.idric @@ -11,6 +11,26 @@ import EuclideanGeometry -- boundaries. Nothing here computes general cohomology, constructs arbitrary -- quotients, or proves a separation theorem from coordinates. +public export +Dimension : Type +Dimension = Cardinality + +public export +CohomologicalDegree : Type +CohomologicalDegree = Cardinality + +public export +CohomologyRank : Type +CohomologyRank = Cardinality + +public export +EulerCharacteristic : Type +EulerCharacteristic = ±Number + +public export +ConnectedComponentCount : Type +ConnectedComponentCount = Number + -- -------------------------------------------------------------------------- -- Spheres in explicitly Euclidean ambient spaces -- -------------------------------------------------------------------------- @@ -28,7 +48,7 @@ data UnitSpherePoint : {space : FiniteSpace} → {structure : EuclideanStructure space} → (coordinates : ExactVectorSample space) → - squared_norm structure coordinates = 1 → + squared_norm structure coordinates = the ±Number 1 → UnitSpherePoint structure -- S^2 is represented in the named Euclidean R^3 fixture. The norm-one @@ -43,7 +63,7 @@ north_pole_s2 = -- only nonzero ranks are in degrees 0 and n. This is a closed standard fact, -- not a general cohomology calculation. public export -sphere_integral_cohomology_rank : Number → Number → Number +sphere_integral_cohomology_rank : Dimension → CohomologicalDegree → CohomologyRank sphere_integral_cohomology_rank Z Z = 2 sphere_integral_cohomology_rank Z (S degree) = 0 sphere_integral_cohomology_rank (S dimension) Z = 1 @@ -59,15 +79,15 @@ flip_parity Even = Odd flip_parity Odd = Even public export -number_parity : Number → Parity -number_parity Z = Even -number_parity (S n) = flip_parity (number_parity n) +dimension_parity : Dimension → Parity +dimension_parity Z = Even +dimension_parity (S n) = flip_parity (dimension_parity n) -- chi(S^n) = 1 + (-1)^n. public export -sphere_euler_characteristic : Number → Integer +sphere_euler_characteristic : Dimension → EulerCharacteristic sphere_euler_characteristic dimension = - case number_parity dimension of + case dimension_parity dimension of Even ⇒ 2 Odd ⇒ 0 @@ -77,21 +97,21 @@ sphere_euler_characteristic dimension = -- CP^n has complex dimension n and real dimension 2n. public export -cp_real_dimension : Number → Number +cp_real_dimension : Dimension → Dimension cp_real_dimension n = n + n -- CP^n has the standard Hopf presentation S^(2n+1) / S^1. This returns the -- dimension of the sphere in that presentation; it does not implement quotient -- equality or construct projective space. public export -cp_hopf_sphere_dimension : Number → Number +cp_hopf_sphere_dimension : Dimension → Dimension cp_hopf_sphere_dimension n = S (n + n) -- Additive integral cohomology ranks of CP^n are one in even degrees -- 0,2,...,2n and zero otherwise. The ring structure is deliberately outside -- this small fact table. public export -cp_integral_cohomology_rank : Number → Number → Number +cp_integral_cohomology_rank : Dimension → CohomologicalDegree → CohomologyRank cp_integral_cohomology_rank n Z = 1 cp_integral_cohomology_rank Z (S degree) = 0 cp_integral_cohomology_rank (S n) (S Z) = 0 @@ -99,11 +119,11 @@ cp_integral_cohomology_rank (S n) (S (S degree)) = cp_integral_cohomology_rank n degree public export -data HopfQuotientFact : Number → Type where - CPnAsSphereByCircle : (n : Number) → HopfQuotientFact n +data HopfQuotientFact : Dimension → Type where + CPnAsSphereByCircle : (n : Dimension) → HopfQuotientFact n public export -cp_hopf_quotient : (n : Number) → HopfQuotientFact n +cp_hopf_quotient : (n : Dimension) → HopfQuotientFact n cp_hopf_quotient n = CPnAsSphereByCircle n -- -------------------------------------------------------------------------- @@ -134,24 +154,24 @@ jordan_separation curve = ExactlyTwoComplementComponents curve public export complement_component_count : - {curve : EmbeddedCircleInS2} → JordanSeparation curve → Number + {curve : EmbeddedCircleInS2} → JordanSeparation curve → ConnectedComponentCount complement_component_count (ExactlyTwoComplementComponents curve) = 2 -- The one-point compactification of Euclidean R^n is S^n. The family is -- indexed explicitly so this fact cannot be mistaken for a generic -- compactification operation on arbitrary spaces. public export -data EuclideanCompactificationFact : Number → Type where +data EuclideanCompactificationFact : Dimension → Type where EuclideanPlusIsSphere : - (dimension : Number) → EuclideanCompactificationFact dimension + (dimension : Dimension) → EuclideanCompactificationFact dimension public export euclidean_one_point_compactification : - (dimension : Number) → EuclideanCompactificationFact dimension + (dimension : Dimension) → EuclideanCompactificationFact dimension euclidean_one_point_compactification dimension = EuclideanPlusIsSphere dimension public export compactified_sphere_dimension : - {n : Number} → EuclideanCompactificationFact n → Number + {n : Dimension} → EuclideanCompactificationFact n → Dimension compactified_sphere_dimension (EuclideanPlusIsSphere dimension) = dimension diff --git a/_/koans/01-values-types-and-holes/exercise/Main.idric b/_/koans/01-values-types-and-holes/exercise/Main.idric index 23264768e8..a0998bff7e 100644 --- a/_/koans/01-values-types-and-holes/exercise/Main.idric +++ b/_/koans/01-values-types-and-holes/exercise/Main.idric @@ -2,7 +2,7 @@ module Main -- Compile this file and read the types reported for these named holes. answer : Number -answer = ?natural_number +answer = ?number_value message : Text message = ?text_value diff --git a/_/koans/01-values-types-and-holes/expected-diagnostic b/_/koans/01-values-types-and-holes/expected-diagnostic index e35b171330..bf4934857f 100644 --- a/_/koans/01-values-types-and-holes/expected-diagnostic +++ b/_/koans/01-values-types-and-holes/expected-diagnostic @@ -1,2 +1,2 @@ -natural_number +number_value text_value diff --git a/_/koans/01-values-types-and-holes/holes b/_/koans/01-values-types-and-holes/holes index e35b171330..bf4934857f 100644 --- a/_/koans/01-values-types-and-holes/holes +++ b/_/koans/01-values-types-and-holes/holes @@ -1,2 +1,2 @@ -natural_number +number_value text_value diff --git a/_/koans/02-functions-with-unicode-arrows/solution/Main.idric b/_/koans/02-functions-with-unicode-arrows/solution/Main.idric index 4333db3c03..99a0c0f1f0 100644 --- a/_/koans/02-functions-with-unicode-arrows/solution/Main.idric +++ b/_/koans/02-functions-with-unicode-arrows/solution/Main.idric @@ -1,7 +1,7 @@ module Main increment : Number → Number -increment = \number ⇒ S number +increment = \number ⇒ number + 1 twice : (a → a) → a → a twice = \function ⇒ \value ⇒ function (function value) diff --git a/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric b/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric index 5bfd478ee3..e40eaab067 100644 --- a/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric @@ -15,4 +15,4 @@ prepend value values = ?longer_list main : IO () main = do printLn (List.length numbers) - printLn (prepend 0 exactly_three) + printLn (prepend 1 exactly_three) diff --git a/_/koans/03-lists-and-length-indexed-lists/expected b/_/koans/03-lists-and-length-indexed-lists/expected index 3487407098..25b93ad9d1 100644 --- a/_/koans/03-lists-and-length-indexed-lists/expected +++ b/_/koans/03-lists-and-length-indexed-lists/expected @@ -1,2 +1,2 @@ 3 -[0, 2, 4, 6] +[1, 2, 4, 6] diff --git a/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric b/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric index 85b98d3248..cb2b43008c 100644 --- a/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric @@ -15,4 +15,4 @@ prepend value values = value :: values main : IO () main = do printLn (List.length numbers) - printLn (prepend 0 exactly_three) + printLn (prepend 1 exactly_three) diff --git a/_/koans/06-implicit-dependent-results/exercise/Main.idric b/_/koans/06-implicit-dependent-results/exercise/Main.idric index baf33de2e5..9b9d3abbb7 100644 --- a/_/koans/06-implicit-dependent-results/exercise/Main.idric +++ b/_/koans/06-implicit-dependent-results/exercise/Main.idric @@ -2,8 +2,8 @@ module Main import Data.Vect --- n is inferred from values; the result type depends on that inferred value. -prepend : {n : Number} → a → Vect n a → Vect (S n) a +-- The zero-capable cardinality is inferred from the compatibility Vect value. +prepend : {n : Cardinality} → a → Vect n a → Vect (S n) a prepend item items = ?dependent_result main : IO () diff --git a/_/koans/06-implicit-dependent-results/solution/Main.idric b/_/koans/06-implicit-dependent-results/solution/Main.idric index a2cd47b03d..8dd86edf06 100644 --- a/_/koans/06-implicit-dependent-results/solution/Main.idric +++ b/_/koans/06-implicit-dependent-results/solution/Main.idric @@ -2,7 +2,7 @@ module Main import Data.Vect -prepend : {n : Number} → a → Vect n a → Vect (S n) a +prepend : {n : Cardinality} → a → Vect n a → Vect (S n) a prepend item items = item :: items main : IO () diff --git a/_/koans/07-erased-arguments/expected-diagnostic b/_/koans/07-erased-arguments/expected-diagnostic index 70493c34dc..63a14f190e 100644 --- a/_/koans/07-erased-arguments/expected-diagnostic +++ b/_/koans/07-erased-arguments/expected-diagnostic @@ -1,2 +1,2 @@ runtime_number_only -0 compile_time_number : Nat +0 compile_time_number : Number diff --git a/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric b/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric index 24bff826f4..e2c9bd9e61 100644 --- a/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric +++ b/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric @@ -1,7 +1,7 @@ module Main choice touch_beginning one_of - near_existing Number + near_existing Cardinality empty_domain describe : touch_beginning → Text diff --git a/_/koans/10-exhaustive-choice-patterns/solution/Main.idric b/_/koans/10-exhaustive-choice-patterns/solution/Main.idric index 1292af67c3..ea4e6af4be 100644 --- a/_/koans/10-exhaustive-choice-patterns/solution/Main.idric +++ b/_/koans/10-exhaustive-choice-patterns/solution/Main.idric @@ -1,7 +1,7 @@ module Main choice touch_beginning one_of - near_existing Number + near_existing Cardinality empty_domain describe : touch_beginning → Text diff --git a/_/koans/11-source-boundaries/exercise/IdrisCompatibility.idr b/_/koans/11-source-boundaries/exercise/IdrisCompatibility.idr index e661a0edbb..b88beb3be3 100644 --- a/_/koans/11-source-boundaries/exercise/IdrisCompatibility.idr +++ b/_/koans/11-source-boundaries/exercise/IdrisCompatibility.idr @@ -12,5 +12,5 @@ joined→⇒←≤name : Nat joined→⇒←≤name = 40 export -compatibility_value : Nat -compatibility_value = choice (one_of joined→⇒←≤name) +compatibility_value : Number +compatibility_value = OneMore (choice joined→⇒←≤name) diff --git a/_/koans/11-source-boundaries/exercise/Main.idric b/_/koans/11-source-boundaries/exercise/Main.idric index e10dc9702e..977d64d95f 100644 --- a/_/koans/11-source-boundaries/exercise/Main.idric +++ b/_/koans/11-source-boundaries/exercise/Main.idric @@ -3,7 +3,7 @@ module Main import IdrisCompatibility increment : Number → Number -increment = \value ⇒ S value +increment = \value ⇒ value + 1 boundary_value : Number boundary_value = ?value_from_both_languages diff --git a/_/koans/11-source-boundaries/solution/IdrisCompatibility.idr b/_/koans/11-source-boundaries/solution/IdrisCompatibility.idr index e661a0edbb..b88beb3be3 100644 --- a/_/koans/11-source-boundaries/solution/IdrisCompatibility.idr +++ b/_/koans/11-source-boundaries/solution/IdrisCompatibility.idr @@ -12,5 +12,5 @@ joined→⇒←≤name : Nat joined→⇒←≤name = 40 export -compatibility_value : Nat -compatibility_value = choice (one_of joined→⇒←≤name) +compatibility_value : Number +compatibility_value = OneMore (choice joined→⇒←≤name) diff --git a/_/koans/11-source-boundaries/solution/Main.idric b/_/koans/11-source-boundaries/solution/Main.idric index 43d92ab305..d2812a3c9c 100644 --- a/_/koans/11-source-boundaries/solution/Main.idric +++ b/_/koans/11-source-boundaries/solution/Main.idric @@ -3,7 +3,7 @@ module Main import IdrisCompatibility increment : Number → Number -increment = \value ⇒ S value +increment = \value ⇒ value + 1 boundary_value : Number boundary_value = increment compatibility_value diff --git a/_/koans/12-wegert-model/exercise/Main.idric b/_/koans/12-wegert-model/exercise/Main.idric index f8eaa88e1c..36edaf3460 100644 --- a/_/koans/12-wegert-model/exercise/Main.idric +++ b/_/koans/12-wegert-model/exercise/Main.idric @@ -7,16 +7,16 @@ choice placement_kind one_of new_pole choice placed_point one_of - zero_at Number - pole_at Number + zero_at ±Number + pole_at ±Number -make_point : placement_kind → Number → placed_point +make_point : placement_kind → ±Number → placed_point make_point new_zero coordinate = ?zero_point make_point new_pole coordinate = ?pole_point place : (kind : placement_kind) → - (coordinate : Number) → + (coordinate : ±Number) → (points : Vect n placed_point) → (updated : Vect (S n) placed_point ** Vect.head updated = make_point kind coordinate) @@ -26,7 +26,7 @@ describe_point : placed_point → Text describe_point (zero_at coordinate) = "zero at " ++ show coordinate describe_point (pole_at coordinate) = "pole at " ++ show coordinate -first_description : placement_kind → Number → Vect n placed_point → Text +first_description : placement_kind → ±Number → Vect n placed_point → Text first_description kind coordinate points = let (updated ** first_is_new) = place kind coordinate points in describe_point (Vect.head updated) diff --git a/_/koans/12-wegert-model/solution/Main.idric b/_/koans/12-wegert-model/solution/Main.idric index 848f155397..3a4c0620d4 100644 --- a/_/koans/12-wegert-model/solution/Main.idric +++ b/_/koans/12-wegert-model/solution/Main.idric @@ -7,16 +7,16 @@ choice placement_kind one_of new_pole choice placed_point one_of - zero_at Number - pole_at Number + zero_at ±Number + pole_at ±Number -make_point : placement_kind → Number → placed_point +make_point : placement_kind → ±Number → placed_point make_point new_zero coordinate = zero_at coordinate make_point new_pole coordinate = pole_at coordinate place : (kind : placement_kind) → - (coordinate : Number) → + (coordinate : ±Number) → (points : Vect n placed_point) → (updated : Vect (S n) placed_point ** Vect.head updated = make_point kind coordinate) @@ -27,7 +27,7 @@ describe_point : placed_point → Text describe_point (zero_at coordinate) = "zero at " ++ show coordinate describe_point (pole_at coordinate) = "pole at " ++ show coordinate -first_description : placement_kind → Number → Vect n placed_point → Text +first_description : placement_kind → ±Number → Vect n placed_point → Text first_description kind coordinate points = let (updated ** first_is_new) = place kind coordinate points in describe_point (Vect.head updated) diff --git a/_/libs/prelude/Prelude/Cast.idr b/_/libs/prelude/Prelude/Cast.idr index d362485ed9..a9e803a3bf 100644 --- a/_/libs/prelude/Prelude/Cast.idr +++ b/_/libs/prelude/Prelude/Cast.idr @@ -100,6 +100,20 @@ export %inline Cast Nat Integer where cast = natToInteger +||| Widening a positive Idriç `Number` to `±Number` is lossless. +export %inline +Cast Number ±Number where + cast = numberAsSigned + +||| Explicit bootstrap representation boundaries for the signed source type. +export %inline +Cast ±Number Integer where + cast = signedAsInteger + +export %inline +Cast Integer ±Number where + cast = SignedValue + export %inline Cast Bits8 Integer where cast = prim__cast_Bits8Integer diff --git a/_/libs/prelude/Prelude/Num.idr b/_/libs/prelude/Prelude/Num.idr index 8a2763b5be..c7ea2e8bff 100644 --- a/_/libs/prelude/Prelude/Num.idr +++ b/_/libs/prelude/Prelude/Num.idr @@ -22,6 +22,29 @@ interface Num ty where %allow_overloads fromInteger +||| Source-facing Idriç addition. Most ordinary numeric representations obtain +||| this operation from `Num`; types with stricter invariants can provide a +||| result-preserving implementation without inventing a literal conversion. +public export +interface IdricAddition ty where + constructor MkIdricAddition + (+~+) : ty -> ty -> ty + +public export %hint +idricAdditionFromNum : Num ty => IdricAddition ty +idricAdditionFromNum = MkIdricAddition (+) + +||| Source-facing Idriç multiplication, separated from literal construction +||| for the same reason as `IdricAddition`. +public export +interface IdricMultiplication ty where + constructor MkIdricMultiplication + (*~*) : ty -> ty -> ty + +public export %hint +idricMultiplicationFromNum : Num ty => IdricMultiplication ty +idricMultiplicationFromNum = MkIdricMultiplication (*) + ||| The `Neg` interface defines operations on numbers which can be negative. public export interface Num ty => Neg ty where @@ -30,6 +53,21 @@ interface Num ty => Neg ty where negate : ty -> ty (-) : ty -> ty -> ty +||| Source-facing Idriç subtraction permits the result type to be wider than +||| its operands. In particular, `Number - Number` produces `±Number`. +public export +interface IdricSubtraction operand result | operand where + constructor MkIdricSubtraction + (-~-) : operand -> operand -> result + +public export %hint +idricSubtractionFromNeg : Neg ty => IdricSubtraction ty ty +idricSubtractionFromNeg = MkIdricSubtraction (-) + +public export +idricNegate : Neg ty => ty -> ty +idricNegate = negate + ||| A convenience alias for `(-)`, this function enables partial application of subtraction on the ||| right-hand operand as ||| ```idris example diff --git a/_/libs/prelude/Prelude/Ops.idr b/_/libs/prelude/Prelude/Ops.idr index ed5d59bb50..9018f3cd61 100644 --- a/_/libs/prelude/Prelude/Ops.idr +++ b/_/libs/prelude/Prelude/Ops.idr @@ -4,6 +4,8 @@ module Prelude.Ops export infix 6 ==, /=, <, <=, >, >= export infixl 8 +, - export infixl 9 *, / +export infixl 8 +~+, -~- +export infixl 9 *~* -- Boolean operators export infixr 5 && diff --git a/_/libs/prelude/Prelude/Show.idr b/_/libs/prelude/Prelude/Show.idr index d0217c4076..2a36e97c7d 100644 --- a/_/libs/prelude/Prelude/Show.idr +++ b/_/libs/prelude/Prelude/Show.idr @@ -193,6 +193,14 @@ export Show Nat where show n = show (the Integer (natToInteger n)) +export +Show Number where + show n = show (signedAsInteger (numberAsSigned n)) + +export +Show ±Number where + show n = show (signedAsInteger n) + export Show Bool where show True = "True" diff --git a/_/libs/prelude/Prelude/Types.idr b/_/libs/prelude/Prelude/Types.idr index fd1eca0fe8..9b46466e99 100644 --- a/_/libs/prelude/Prelude/Types.idr +++ b/_/libs/prelude/Prelude/Types.idr @@ -102,6 +102,110 @@ natToInteger (S k) = 1 + natToInteger k -- %builtin NaturalToInteger Prelude.Types.natToInteger +------------------- +-- IDRIC NUMBERS -- +------------------- + +||| The ordinary positive whole numbers: 1, 2, 3, and so on. +||| +||| `Number` deliberately has no zero constructor. The stored `Nat` is the +||| predecessor used by the bootstrap representation, not the Idriç meaning. +public export +data Number = OneMore Nat + +%name Number number, left_number, right_number + +||| A cardinality that may be empty. This semantic name keeps zero-capable +||| lengths and counts from being mislabeled as positive `Number` values. +public export +Cardinality : Type +Cardinality = Nat + +||| The ordinary signed whole numbers, including zero. +||| +||| The stored `Integer` is the bootstrap representation. Idriç programs use +||| this distinct type so representation names do not leak into diagnostics or +||| overload selection. +public export +data ±Number = SignedValue Integer + +%name ±Number signed_number, left_signed_number, right_signed_number + +||| Construct a `Number` literal only when the literal is strictly positive. +||| The proof is resolved during elaboration for a concrete source literal. +public export +positiveNumberFromInteger : (value : Integer) -> + {auto 0 positive : value > 0 = True} -> + Number +positiveNumberFromInteger value = OneMore $ + integerToNat (prim__sub_Integer value 1) + +||| Construct a zero-capable cardinality from a nonnegative source literal. +||| `Cardinality` is a domain name for counts and sizes, not a signed number. +public export +cardinalityFromInteger : (value : Integer) -> + {auto 0 nonnegative : value >= 0 = True} -> + Cardinality +cardinalityFromInteger value = integerToNat value + +||| Widen a positive `Number` to the signed number type. +public export +numberAsSigned : Number -> ±Number +numberAsSigned (OneMore predecessor) = + SignedValue (prim__add_Integer 1 (natToInteger predecessor)) + +||| Cross the bootstrap representation boundary explicitly. +public export +signedAsInteger : ±Number -> Integer +signedAsInteger (SignedValue value) = value + +public export +IdricAddition Number where + (+~+) (OneMore left) (OneMore right) = OneMore (S (plus left right)) + +public export +IdricMultiplication Number where + (*~*) (OneMore left) (OneMore right) = + OneMore (plus left (plus right (mult left right))) + +||| Subtracting positive numbers may produce a negative value or zero. +public export +IdricSubtraction Number ±Number where + (-~-) left right = SignedValue $ + prim__sub_Integer + (signedAsInteger (numberAsSigned left)) + (signedAsInteger (numberAsSigned right)) + +public export +Eq Number where + OneMore left == OneMore right = left == right + +public export +Ord Number where + compare (OneMore left) (OneMore right) = compare left right + +public export +Eq ±Number where + SignedValue left == SignedValue right = left == right + +public export +Ord ±Number where + compare (SignedValue left) (SignedValue right) = compare left right + +public export +Num ±Number where + SignedValue left + SignedValue right = + SignedValue (prim__add_Integer left right) + SignedValue left * SignedValue right = + SignedValue (prim__mul_Integer left right) + fromInteger = SignedValue + +public export +Neg ±Number where + negate (SignedValue value) = SignedValue (prim__sub_Integer 0 value) + SignedValue left - SignedValue right = + SignedValue (prim__sub_Integer left right) + ||| Counts the number of elements that satisfy a predicate. public export count : Foldable t => (predicate : a -> Bool) -> t a -> Nat diff --git a/_/tests/idris2/basic/edric003/Main.idric b/_/tests/idris2/basic/edric003/Main.idric index fbca646de8..b33eaa916c 100644 --- a/_/tests/idris2/basic/edric003/Main.idric +++ b/_/tests/idris2/basic/edric003/Main.idric @@ -16,10 +16,10 @@ describe_placement : placement_kind → Text describe_placement new_zero = "new_zero" describe_placement new_pole = "new_pole" -chain_depth : recursive_chain → Number +chain_depth : recursive_chain → Cardinality chain_depth chain_end = Z chain_depth (chain_link chain_end) = 1 -chain_depth (chain_link (chain_link rest)) = 2 + chain_depth rest +chain_depth (chain_link (chain_link rest)) = chain_depth rest + 2 identity : a → a identity value = value diff --git a/_/tests/idris2/basic/edric003/WegertTouch.idric b/_/tests/idris2/basic/edric003/WegertTouch.idric index cddf741c65..8252c0e83f 100644 --- a/_/tests/idris2/basic/edric003/WegertTouch.idric +++ b/_/tests/idris2/basic/edric003/WegertTouch.idric @@ -1,10 +1,14 @@ module WegertTouch +public export +TouchCoordinate : Type +TouchCoordinate = ±Number + public export choice existing_touch_target one_of - fixed_value Number - zero Number - pole Number + fixed_value TouchCoordinate + zero TouchCoordinate + pole TouchCoordinate public export choice touch_beginning one_of diff --git a/_/tests/idris2/basic/edric005/Main.idric b/_/tests/idris2/basic/edric005/Main.idric index d7a9f77cce..f45dcba17d 100644 --- a/_/tests/idris2/basic/edric005/Main.idric +++ b/_/tests/idris2/basic/edric005/Main.idric @@ -3,13 +3,13 @@ module Main import Data.Text import IdrisCompat -unicode_function : Integer→Integer +unicode_function : ±Number→±Number unicode_function = \value⇒value + 1 -unicode_apply : (Integer→Integer)→Integer→Integer +unicode_apply : (±Number→±Number)→±Number→±Number unicode_apply = \function⇒\value⇒function value -ascii_function : Integer -> Integer +ascii_function : ±Number -> ±Number ascii_function = \value => value + 1 unicode_order : Bool diff --git a/_/tests/idris2/basic/edric010/IdrisCompatibility.idr b/_/tests/idris2/basic/edric010/IdrisCompatibility.idr new file mode 100644 index 0000000000..335b70d091 --- /dev/null +++ b/_/tests/idris2/basic/edric010/IdrisCompatibility.idr @@ -0,0 +1,10 @@ +module IdrisCompatibility + +ordinary_nat : Nat +ordinary_nat = 0 + +ordinary_integer : Integer +ordinary_integer = -1 + +ordinary_sum : Integer +ordinary_sum = 1 + 2 diff --git a/_/tests/idris2/basic/edric010/NegativeIsNotNumber.idric b/_/tests/idris2/basic/edric010/NegativeIsNotNumber.idric new file mode 100644 index 0000000000..a878242bf8 --- /dev/null +++ b/_/tests/idris2/basic/edric010/NegativeIsNotNumber.idric @@ -0,0 +1,4 @@ +module NegativeIsNotNumber + +invalid_negative : Number +invalid_negative = -1 diff --git a/_/tests/idris2/basic/edric010/Valid.idric b/_/tests/idris2/basic/edric010/Valid.idric new file mode 100644 index 0000000000..0d98e254d4 --- /dev/null +++ b/_/tests/idris2/basic/edric010/Valid.idric @@ -0,0 +1,34 @@ +module Valid + +one : Number +one = 1 + +two : Number +two = 2 + +minus_one : ±Number +minus_one = -1 + +unicode_minus_one : ±Number +unicode_minus_one = −1 + +zero : ±Number +zero = 0 + +positive_signed : ±Number +positive_signed = 1 + +difference : ±Number +difference = one - two + +positive_sum : Number +positive_sum = one + two + +positive_product : Number +positive_product = one * two + +accept_signed : ±Number -> ±Number +accept_signed value = value + +widened : ±Number +widened = accept_signed (numberAsSigned one) diff --git a/_/tests/idris2/basic/edric010/ZeroIsNotNumber.idric b/_/tests/idris2/basic/edric010/ZeroIsNotNumber.idric new file mode 100644 index 0000000000..95b1944b1b --- /dev/null +++ b/_/tests/idris2/basic/edric010/ZeroIsNotNumber.idric @@ -0,0 +1,4 @@ +module ZeroIsNotNumber + +invalid_zero : Number +invalid_zero = 0 diff --git a/_/tests/idris2/basic/edric010/expected b/_/tests/idris2/basic/edric010/expected new file mode 100644 index 0000000000..6256974e29 --- /dev/null +++ b/_/tests/idris2/basic/edric010/expected @@ -0,0 +1,4 @@ +Number and ±Number accepted values and arithmetic: PASS +zero rejected as Number: PASS +negative value rejected as Number: PASS +ordinary .idr numeric inference preserved: PASS diff --git a/_/tests/idris2/basic/edric010/run b/_/tests/idris2/basic/edric010/run new file mode 100755 index 0000000000..043f54d360 --- /dev/null +++ b/_/tests/idris2/basic/edric010/run @@ -0,0 +1,28 @@ +#!/bin/sh +set -eu + +. ../../../testutils.sh + +if ! "$idris2" --check Valid.idric >valid.log 2>&1; then + cat valid.log >&2 + exit 1 +fi +printf '%s\n' 'Number and ±Number accepted values and arithmetic: PASS' + +if "$idris2" --check ZeroIsNotNumber.idric >zero.log 2>&1; then + printf '%s\n' '0 unexpectedly elaborated as Number' >&2 + exit 1 +fi +printf '%s\n' 'zero rejected as Number: PASS' + +if "$idris2" --check NegativeIsNotNumber.idric >negative.log 2>&1; then + printf '%s\n' 'negative literal unexpectedly elaborated as Number' >&2 + exit 1 +fi +printf '%s\n' 'negative value rejected as Number: PASS' + +if ! "$idris2" --check IdrisCompatibility.idr >compatibility.log 2>&1; then + cat compatibility.log >&2 + exit 1 +fi +printf '%s\n' 'ordinary .idr numeric inference preserved: PASS' From 789b635cc30950d0f03fad8b1fcf563aee54d6c5 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:29:39 -0400 Subject: [PATCH 41/80] Add basis-independent quadratic and Hermitian form semantics --- .../QuadraticForms.idric | 1112 +++++++++++++++++ 1 file changed, 1112 insertions(+) create mode 100644 _/examples/unified-higher-mathematics/QuadraticForms.idric diff --git a/_/examples/unified-higher-mathematics/QuadraticForms.idric b/_/examples/unified-higher-mathematics/QuadraticForms.idric new file mode 100644 index 0000000000..215084dd7f --- /dev/null +++ b/_/examples/unified-higher-mathematics/QuadraticForms.idric @@ -0,0 +1,1112 @@ +module QuadraticForms + +import MathematicalSpaces + +%default total +%unbound_implicits off + +-- Forms in this module are mathematical objects. Matrices appear only in the +-- representation section, where a chosen basis is part of the type. The +-- current higher-mathematics slice has exact Integer vector samples rather than +-- a general scalar-field/module hierarchy, so the ordinary forms below are an +-- exact integral model. QuadraticForm remains a distinct type from +-- SymmetricBilinearForm even here: that distinction is required before a +-- future scalar abstraction can honestly include characteristic 2. + +-- -------------------------------------------------------------------------- +-- Bilinear, symmetric bilinear, and quadratic forms +-- -------------------------------------------------------------------------- + +public export +data BilinearForm : FiniteSpace -> Type where + BilinearZero : BilinearForm space + BilinearTensor : + ExactCovectorSample space -> + ExactCovectorSample space -> + BilinearForm space + BilinearSum : BilinearForm space -> BilinearForm space -> BilinearForm space + BilinearScale : Integer -> BilinearForm space -> BilinearForm space + +public export +evaluate_bilinear : + {space : FiniteSpace} -> + BilinearForm space -> + ExactVectorSample space -> + ExactVectorSample space -> + Integer +evaluate_bilinear BilinearZero left right = 0 +evaluate_bilinear (BilinearTensor first second) left right = + contract first left * contract second right +evaluate_bilinear (BilinearSum first second) left right = + evaluate_bilinear first left right + evaluate_bilinear second left right +evaluate_bilinear (BilinearScale scalar form) left right = + scalar * evaluate_bilinear form left right + +-- Fixing the first argument gives an honest covector, rather than coercing a +-- vector into one. This is the currently expressible part of B : V -> V*. +public export +bilinear_covector_at : + {space : FiniteSpace} -> + BilinearForm space -> + ExactVectorSample space -> + ExactCovectorSample space +bilinear_covector_at BilinearZero vector = scaleCovector 0 (zero_covector vector) +bilinear_covector_at (BilinearTensor first second) vector = + scaleCovector (contract first vector) second +bilinear_covector_at (BilinearSum first second) vector = + addCovector + (bilinear_covector_at first vector) + (bilinear_covector_at second vector) +bilinear_covector_at (BilinearScale scalar form) vector = + scaleCovector scalar (bilinear_covector_at form vector) + +-- The zero covector is constructed from the vector's named-space index without +-- identifying the vector with its dual. +zero_covector : + {space : FiniteSpace} -> + ExactVectorSample space -> + ExactCovectorSample space +zero_covector (UnsafeVectorCoordinates coordinates) = + UnsafeCovectorCoordinates + (unsafeZeroCoordinates (spaceRank space)) + +public export +data SymmetricBilinearForm : FiniteSpace -> Type where + SymmetricZero : SymmetricBilinearForm space + SymmetricSquare : ExactCovectorSample space -> SymmetricBilinearForm space + SymmetricPair : + ExactCovectorSample space -> + ExactCovectorSample space -> + SymmetricBilinearForm space + SymmetricSum : + SymmetricBilinearForm space -> + SymmetricBilinearForm space -> + SymmetricBilinearForm space + SymmetricScale : Integer -> SymmetricBilinearForm space -> SymmetricBilinearForm space + +public export +evaluate_symmetric : + {space : FiniteSpace} -> + SymmetricBilinearForm space -> + ExactVectorSample space -> + ExactVectorSample space -> + Integer +evaluate_symmetric SymmetricZero left right = 0 +evaluate_symmetric (SymmetricSquare covector) left right = + contract covector left * contract covector right +evaluate_symmetric (SymmetricPair first second) left right = + contract first left * contract second right + + contract second left * contract first right +evaluate_symmetric (SymmetricSum first second) left right = + evaluate_symmetric first left right + evaluate_symmetric second left right +evaluate_symmetric (SymmetricScale scalar form) left right = + scalar * evaluate_symmetric form left right + +public export +symmetric_as_bilinear : + {space : FiniteSpace} -> + SymmetricBilinearForm space -> + BilinearForm space +symmetric_as_bilinear SymmetricZero = BilinearZero +symmetric_as_bilinear (SymmetricSquare covector) = + BilinearTensor covector covector +symmetric_as_bilinear (SymmetricPair first second) = + BilinearSum + (BilinearTensor first second) + (BilinearTensor second first) +symmetric_as_bilinear (SymmetricSum first second) = + BilinearSum (symmetric_as_bilinear first) (symmetric_as_bilinear second) +symmetric_as_bilinear (SymmetricScale scalar form) = + BilinearScale scalar (symmetric_as_bilinear form) + +public export +symmetric_covector_at : + {space : FiniteSpace} -> + SymmetricBilinearForm space -> + ExactVectorSample space -> + ExactCovectorSample space +symmetric_covector_at form vector = + bilinear_covector_at (symmetric_as_bilinear form) vector + +-- QuadraticForm is primitive. In particular QuadraticProduct permits an +-- integral cross term q(v)=alpha(v) beta(v) without pretending that it arose +-- as the diagonal of an integral symmetric bilinear form. Over scalars where +-- 2 is invertible, stronger conversion machinery can be layered on later. +public export +data QuadraticForm : FiniteSpace -> Type where + QuadraticZero : QuadraticForm space + QuadraticSquare : ExactCovectorSample space -> QuadraticForm space + QuadraticProduct : + ExactCovectorSample space -> + ExactCovectorSample space -> + QuadraticForm space + QuadraticSum : QuadraticForm space -> QuadraticForm space -> QuadraticForm space + QuadraticScale : Integer -> QuadraticForm space -> QuadraticForm space + QuadraticFromSymmetric : SymmetricBilinearForm space -> QuadraticForm space + +public export +evaluate_quadratic : + {space : FiniteSpace} -> + QuadraticForm space -> + ExactVectorSample space -> + Integer +evaluate_quadratic QuadraticZero vector = 0 +evaluate_quadratic (QuadraticSquare covector) vector = + contract covector vector * contract covector vector +evaluate_quadratic (QuadraticProduct first second) vector = + contract first vector * contract second vector +evaluate_quadratic (QuadraticSum first second) vector = + evaluate_quadratic first vector + evaluate_quadratic second vector +evaluate_quadratic (QuadraticScale scalar form) vector = + scalar * evaluate_quadratic form vector +evaluate_quadratic (QuadraticFromSymmetric form) vector = + evaluate_symmetric form vector vector + +public export +quadratic_from_symmetric : + {space : FiniteSpace} -> + SymmetricBilinearForm space -> + QuadraticForm space +quadratic_from_symmetric = QuadraticFromSymmetric + +-- The unhalved polar form exists integrally. It is deliberately not exposed +-- as an inverse to quadratic_from_symmetric: +-- polar(q)(x,y) = q(x+y)-q(x)-q(y) +-- and polar(B(v,v)) = 2 B over this exact integral scalar model. +public export +polar_form : + {space : FiniteSpace} -> + QuadraticForm space -> + SymmetricBilinearForm space +polar_form QuadraticZero = SymmetricZero +polar_form (QuadraticSquare covector) = + SymmetricScale 2 (SymmetricSquare covector) +polar_form (QuadraticProduct first second) = + SymmetricPair first second +polar_form (QuadraticSum first second) = + SymmetricSum (polar_form first) (polar_form second) +polar_form (QuadraticScale scalar form) = + SymmetricScale scalar (polar_form form) +polar_form (QuadraticFromSymmetric form) = + SymmetricScale 2 form + +public export +polar_difference : + {space : FiniteSpace} -> + QuadraticForm space -> + ExactVectorSample space -> + ExactVectorSample space -> + Integer +polar_difference form left right = + evaluate_quadratic form (addVector left right) + - evaluate_quadratic form left + - evaluate_quadratic form right + +-- Evidence that a particular integral quadratic form is known to be the +-- diagonal of an integral symmetric bilinear form. There is intentionally no +-- constructor for a general QuadraticProduct: an odd cross term would require +-- division by 2 in the symmetric matrix. +public export +data DiagonalPresentation : + {space : FiniteSpace} -> QuadraticForm space -> Type where + SquareHasDiagonalPresentation : + (covector : ExactCovectorSample space) -> + DiagonalPresentation (QuadraticSquare covector) + SymmetricHasDiagonalPresentation : + (form : SymmetricBilinearForm space) -> + DiagonalPresentation (QuadraticFromSymmetric form) + SumHasDiagonalPresentation : + {first : QuadraticForm space} -> + {second : QuadraticForm space} -> + DiagonalPresentation first -> + DiagonalPresentation second -> + DiagonalPresentation (QuadraticSum first second) + ScaleHasDiagonalPresentation : + (scalar : Integer) -> + {form : QuadraticForm space} -> + DiagonalPresentation form -> + DiagonalPresentation (QuadraticScale scalar form) + +public export +presented_symmetric_form : + {space : FiniteSpace} -> + {form : QuadraticForm space} -> + DiagonalPresentation form -> + SymmetricBilinearForm space +presented_symmetric_form (SquareHasDiagonalPresentation covector) = + SymmetricSquare covector +presented_symmetric_form (SymmetricHasDiagonalPresentation form) = form +presented_symmetric_form (SumHasDiagonalPresentation first second) = + SymmetricSum + (presented_symmetric_form first) + (presented_symmetric_form second) +presented_symmetric_form (ScaleHasDiagonalPresentation scalar form) = + SymmetricScale scalar (presented_symmetric_form form) + +-- -------------------------------------------------------------------------- +-- Exact complex samples, sesquilinear forms, and Hermitian forms +-- -------------------------------------------------------------------------- + +public export +data ExactComplex = Complex Integer Integer + +public export +complex_zero : ExactComplex +complex_zero = Complex 0 0 + +public export +complex_one : ExactComplex +complex_one = Complex 1 0 + +public export +complex_i : ExactComplex +complex_i = Complex 0 1 + +public export +complex_add : ExactComplex -> ExactComplex -> ExactComplex +complex_add (Complex a b) (Complex c d) = Complex (a + c) (b + d) + +public export +complex_negate : ExactComplex -> ExactComplex +complex_negate (Complex a b) = Complex (-a) (-b) + +public export +complex_subtract : ExactComplex -> ExactComplex -> ExactComplex +complex_subtract left right = complex_add left (complex_negate right) + +public export +complex_multiply : ExactComplex -> ExactComplex -> ExactComplex +complex_multiply (Complex a b) (Complex c d) = + Complex (a * c - b * d) (a * d + b * c) + +public export +complex_scale_integer : Integer -> ExactComplex -> ExactComplex +complex_scale_integer scalar (Complex real imaginary) = + Complex (scalar * real) (scalar * imaginary) + +public export +conjugate : ExactComplex -> ExactComplex +conjugate (Complex real imaginary) = Complex real (-imaginary) + +public export +real_part : ExactComplex -> Integer +real_part (Complex real imaginary) = real + +public export +imaginary_part : ExactComplex -> Integer +imaginary_part (Complex real imaginary) = imaginary + +public export +data RawExactComplexCoordinates : ℕ -> Type where + UnsafeComplexCoordinateNil : RawExactComplexCoordinates Z + UnsafeComplexCoordinateCons : + {n : ℕ} -> + ExactComplex -> + RawExactComplexCoordinates n -> + RawExactComplexCoordinates (S n) + +public export +data ExactComplexVectorSample : FiniteSpace -> Type where + UnsafeComplexVectorCoordinates : + {rank : ℕ} -> + {name : SpaceName rank} -> + RawExactComplexCoordinates rank -> + ExactComplexVectorSample (NamedFiniteSpace name) + +public export +data ExactComplexCovectorSample : FiniteSpace -> Type where + UnsafeComplexCovectorCoordinates : + {rank : ℕ} -> + {name : SpaceName rank} -> + RawExactComplexCoordinates rank -> + ExactComplexCovectorSample (NamedFiniteSpace name) + +unsafe_zero_complex_coordinates : (n : ℕ) -> RawExactComplexCoordinates n +unsafe_zero_complex_coordinates Z = UnsafeComplexCoordinateNil +unsafe_zero_complex_coordinates (S n) = + UnsafeComplexCoordinateCons complex_zero (unsafe_zero_complex_coordinates n) + +unsafe_add_complex_coordinates : + {n : ℕ} -> + RawExactComplexCoordinates n -> + RawExactComplexCoordinates n -> + RawExactComplexCoordinates n +unsafe_add_complex_coordinates UnsafeComplexCoordinateNil UnsafeComplexCoordinateNil = + UnsafeComplexCoordinateNil +unsafe_add_complex_coordinates + (UnsafeComplexCoordinateCons left left_rest) + (UnsafeComplexCoordinateCons right right_rest) = + UnsafeComplexCoordinateCons + (complex_add left right) + (unsafe_add_complex_coordinates left_rest right_rest) + +unsafe_scale_complex_coordinates : + {n : ℕ} -> + ExactComplex -> + RawExactComplexCoordinates n -> + RawExactComplexCoordinates n +unsafe_scale_complex_coordinates scalar UnsafeComplexCoordinateNil = + UnsafeComplexCoordinateNil +unsafe_scale_complex_coordinates scalar (UnsafeComplexCoordinateCons value rest) = + UnsafeComplexCoordinateCons + (complex_multiply scalar value) + (unsafe_scale_complex_coordinates scalar rest) + +unsafe_pair_complex_coordinates : + {n : ℕ} -> + RawExactComplexCoordinates n -> + RawExactComplexCoordinates n -> + ExactComplex +unsafe_pair_complex_coordinates UnsafeComplexCoordinateNil UnsafeComplexCoordinateNil = + complex_zero +unsafe_pair_complex_coordinates + (UnsafeComplexCoordinateCons left left_rest) + (UnsafeComplexCoordinateCons right right_rest) = + complex_add + (complex_multiply left right) + (unsafe_pair_complex_coordinates left_rest right_rest) + +public export +add_complex_vector : + {space : FiniteSpace} -> + ExactComplexVectorSample space -> + ExactComplexVectorSample space -> + ExactComplexVectorSample space +add_complex_vector + (UnsafeComplexVectorCoordinates left) + (UnsafeComplexVectorCoordinates right) = + UnsafeComplexVectorCoordinates (unsafe_add_complex_coordinates left right) + +public export +scale_complex_vector : + {space : FiniteSpace} -> + ExactComplex -> + ExactComplexVectorSample space -> + ExactComplexVectorSample space +scale_complex_vector scalar (UnsafeComplexVectorCoordinates coordinates) = + UnsafeComplexVectorCoordinates (unsafe_scale_complex_coordinates scalar coordinates) + +public export +add_complex_covector : + {space : FiniteSpace} -> + ExactComplexCovectorSample space -> + ExactComplexCovectorSample space -> + ExactComplexCovectorSample space +add_complex_covector + (UnsafeComplexCovectorCoordinates left) + (UnsafeComplexCovectorCoordinates right) = + UnsafeComplexCovectorCoordinates (unsafe_add_complex_coordinates left right) + +public export +scale_complex_covector : + {space : FiniteSpace} -> + ExactComplex -> + ExactComplexCovectorSample space -> + ExactComplexCovectorSample space +scale_complex_covector scalar (UnsafeComplexCovectorCoordinates coordinates) = + UnsafeComplexCovectorCoordinates + (unsafe_scale_complex_coordinates scalar coordinates) + +public export +complex_contract : + {space : FiniteSpace} -> + ExactComplexCovectorSample space -> + ExactComplexVectorSample space -> + ExactComplex +complex_contract + (UnsafeComplexCovectorCoordinates covector_coordinates) + (UnsafeComplexVectorCoordinates vector_coordinates) = + unsafe_pair_complex_coordinates covector_coordinates vector_coordinates + +public export +complex_plane_vector : + ExactComplex -> ExactComplex -> ExactComplexVectorSample planeSpace +complex_plane_vector first second = + UnsafeComplexVectorCoordinates + (UnsafeComplexCoordinateCons first + (UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil)) + +public export +complex_plane_covector : + ExactComplex -> ExactComplex -> ExactComplexCovectorSample planeSpace +complex_plane_covector first second = + UnsafeComplexCovectorCoordinates + (UnsafeComplexCoordinateCons first + (UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil)) + +complex_zero_covector : + {space : FiniteSpace} -> + ExactComplexVectorSample space -> + ExactComplexCovectorSample space +complex_zero_covector (UnsafeComplexVectorCoordinates coordinates) = + UnsafeComplexCovectorCoordinates + (unsafe_zero_complex_coordinates (spaceRank space)) + +-- Convention: sesquilinear and Hermitian forms are conjugate-linear in the +-- first argument and linear in the second. +public export +data SesquilinearForm : FiniteSpace -> Type where + SesquilinearZero : SesquilinearForm space + SesquilinearTensor : + ExactComplexCovectorSample space -> + ExactComplexCovectorSample space -> + SesquilinearForm space + SesquilinearSum : + SesquilinearForm space -> + SesquilinearForm space -> + SesquilinearForm space + SesquilinearScale : ExactComplex -> SesquilinearForm space -> SesquilinearForm space + +public export +evaluate_sesquilinear : + {space : FiniteSpace} -> + SesquilinearForm space -> + ExactComplexVectorSample space -> + ExactComplexVectorSample space -> + ExactComplex +evaluate_sesquilinear SesquilinearZero left right = complex_zero +evaluate_sesquilinear (SesquilinearTensor first second) left right = + complex_multiply + (conjugate (complex_contract first left)) + (complex_contract second right) +evaluate_sesquilinear (SesquilinearSum first second) left right = + complex_add + (evaluate_sesquilinear first left right) + (evaluate_sesquilinear second left right) +evaluate_sesquilinear (SesquilinearScale scalar form) left right = + complex_multiply scalar (evaluate_sesquilinear form left right) + +public export +data HermitianForm : FiniteSpace -> Type where + HermitianZero : HermitianForm space + HermitianSquare : ExactComplexCovectorSample space -> HermitianForm space + HermitianCross : + ExactComplex -> + ExactComplexCovectorSample space -> + ExactComplexCovectorSample space -> + HermitianForm space + HermitianSum : HermitianForm space -> HermitianForm space -> HermitianForm space + HermitianScale : Integer -> HermitianForm space -> HermitianForm space + +public export +evaluate_hermitian : + {space : FiniteSpace} -> + HermitianForm space -> + ExactComplexVectorSample space -> + ExactComplexVectorSample space -> + ExactComplex +evaluate_hermitian HermitianZero left right = complex_zero +evaluate_hermitian (HermitianSquare covector) left right = + complex_multiply + (conjugate (complex_contract covector left)) + (complex_contract covector right) +evaluate_hermitian (HermitianCross coefficient first second) left right = + complex_add + (complex_multiply + (complex_multiply + (conjugate (complex_contract first left)) + coefficient) + (complex_contract second right)) + (complex_multiply + (complex_multiply + (conjugate (complex_contract second left)) + (conjugate coefficient)) + (complex_contract first right)) +evaluate_hermitian (HermitianSum first second) left right = + complex_add + (evaluate_hermitian first left right) + (evaluate_hermitian second left right) +evaluate_hermitian (HermitianScale scalar form) left right = + complex_scale_integer scalar (evaluate_hermitian form left right) + +public export +hermitian_as_sesquilinear : + {space : FiniteSpace} -> + HermitianForm space -> + SesquilinearForm space +hermitian_as_sesquilinear HermitianZero = SesquilinearZero +hermitian_as_sesquilinear (HermitianSquare covector) = + SesquilinearTensor covector covector +hermitian_as_sesquilinear (HermitianCross coefficient first second) = + SesquilinearSum + (SesquilinearScale coefficient (SesquilinearTensor first second)) + (SesquilinearScale + (conjugate coefficient) + (SesquilinearTensor second first)) +hermitian_as_sesquilinear (HermitianSum first second) = + SesquilinearSum + (hermitian_as_sesquilinear first) + (hermitian_as_sesquilinear second) +hermitian_as_sesquilinear (HermitianScale scalar form) = + SesquilinearScale + (Complex scalar 0) + (hermitian_as_sesquilinear form) + +-- H(v,v) is real for values built by the closed Hermitian constructors. The +-- exact Gaussian-integer model therefore exposes its real Hermitian quadratic +-- quantity as Integer rather than pretending it is an ordinary complex +-- QuadraticForm. +public export +hermitian_quadratic_quantity : + {space : FiniteSpace} -> + HermitianForm space -> + ExactComplexVectorSample space -> + Integer +hermitian_quadratic_quantity form vector = + real_part (evaluate_hermitian form vector vector) + +-- Fixing the first argument produces a linear complex covector. As a map from +-- the first vector into the dual this operation is conjugate-linear, exactly as +-- the chosen Hermitian convention requires. +public export +hermitian_covector_at : + {space : FiniteSpace} -> + HermitianForm space -> + ExactComplexVectorSample space -> + ExactComplexCovectorSample space +hermitian_covector_at HermitianZero vector = complex_zero_covector vector +hermitian_covector_at (HermitianSquare covector) vector = + scale_complex_covector + (conjugate (complex_contract covector vector)) + covector +hermitian_covector_at (HermitianCross coefficient first second) vector = + add_complex_covector + (scale_complex_covector + (complex_multiply (conjugate (complex_contract first vector)) coefficient) + second) + (scale_complex_covector + (complex_multiply + (conjugate (complex_contract second vector)) + (conjugate coefficient)) + first) +hermitian_covector_at (HermitianSum first second) vector = + add_complex_covector + (hermitian_covector_at first vector) + (hermitian_covector_at second vector) +hermitian_covector_at (HermitianScale scalar form) vector = + scale_complex_covector + (Complex scalar 0) + (hermitian_covector_at form vector) + +-- -------------------------------------------------------------------------- +-- Property certificates on the exact sample family +-- -------------------------------------------------------------------------- + +public export +plane_x : ExactCovectorSample planeSpace +plane_x = planeCovector 1 0 + +public export +plane_y : ExactCovectorSample planeSpace +plane_y = planeCovector 0 1 + +public export +plane_positive_quadratic : QuadraticForm planeSpace +plane_positive_quadratic = + QuadraticSum (QuadraticSquare plane_x) (QuadraticSquare plane_y) + +public export +plane_negative_quadratic : QuadraticForm planeSpace +plane_negative_quadratic = QuadraticScale (-1) plane_positive_quadratic + +public export +plane_first_square : QuadraticForm planeSpace +plane_first_square = QuadraticSquare plane_x + +public export +plane_negative_first_square : QuadraticForm planeSpace +plane_negative_first_square = QuadraticScale (-1) plane_first_square + +public export +plane_difference_of_squares : QuadraticForm planeSpace +plane_difference_of_squares = + QuadraticSum + (QuadraticSquare plane_x) + (QuadraticScale (-1) (QuadraticSquare plane_y)) + +public export +plane_cross_quadratic : QuadraticForm planeSpace +plane_cross_quadratic = QuadraticProduct plane_x plane_y + +public export +data PositiveDefinite : + {space : FiniteSpace} -> QuadraticForm space -> Type where + PlaneSumOfSquaresPositive : PositiveDefinite plane_positive_quadratic + +public export +data NegativeDefinite : + {space : FiniteSpace} -> QuadraticForm space -> Type where + NegativePlaneSumOfSquares : NegativeDefinite plane_negative_quadratic + +public export +data PositiveSemidefinite : + {space : FiniteSpace} -> QuadraticForm space -> Type where + PositiveDefiniteIsSemidefinite : + {form : QuadraticForm space} -> + PositiveDefinite form -> + PositiveSemidefinite form + PlaneFirstSquareSemidefinite : PositiveSemidefinite plane_first_square + +public export +data NegativeSemidefinite : + {space : FiniteSpace} -> QuadraticForm space -> Type where + NegativeDefiniteIsSemidefinite : + {form : QuadraticForm space} -> + NegativeDefinite form -> + NegativeSemidefinite form + NegativePlaneFirstSquareSemidefinite : + NegativeSemidefinite plane_negative_first_square + +public export +data QuadraticNondegenerate : + {space : FiniteSpace} -> QuadraticForm space -> Type where + PositiveDefiniteIsNondegenerate : + {form : QuadraticForm space} -> + PositiveDefinite form -> + QuadraticNondegenerate form + NegativeDefiniteIsNondegenerate : + {form : QuadraticForm space} -> + NegativeDefinite form -> + QuadraticNondegenerate form + PlaneDifferenceOfSquaresNondegenerate : + QuadraticNondegenerate plane_difference_of_squares + +public export +data QuadraticDegenerate : + {space : FiniteSpace} -> QuadraticForm space -> Type where + PlaneFirstSquareDegenerate : QuadraticDegenerate plane_first_square + +public export +data Indefinite : + {space : FiniteSpace} -> QuadraticForm space -> Type where + PlaneDifferenceOfSquaresIndefinite : Indefinite plane_difference_of_squares + +public export +data Isotropic : + {space : FiniteSpace} -> QuadraticForm space -> Type where + PlaneDifferenceOfSquaresIsotropic : Isotropic plane_difference_of_squares + +public export +data Anisotropic : + {space : FiniteSpace} -> QuadraticForm space -> Type where + PositiveDefiniteIsAnisotropic : + {form : QuadraticForm space} -> + PositiveDefinite form -> + Anisotropic form + NegativeDefiniteIsAnisotropic : + {form : QuadraticForm space} -> + NegativeDefinite form -> + Anisotropic form + +-- Every ordinary QuadraticForm in this module is Integer-valued on the exact +-- lattice sample by construction. This certificate should not be generalized +-- to future real/complex vector families without an explicit lattice. +public export +data IntegralQuadratic : + {space : FiniteSpace} -> QuadraticForm space -> Type where + ExactIntegerValued : + (form : QuadraticForm space) -> + IntegralQuadratic form + +-- A doubled integral quadratic form is even. This is a structural certificate +-- rather than a stored Boolean flag. +public export +data EvenQuadratic : + {space : FiniteSpace} -> QuadraticForm space -> Type where + TwiceIntegralFormIsEven : + (form : QuadraticForm space) -> + EvenQuadratic (QuadraticScale 2 form) + +public export +positive_definite_is_nondegenerate : + {space : FiniteSpace} -> + {form : QuadraticForm space} -> + PositiveDefinite form -> + QuadraticNondegenerate form +positive_definite_is_nondegenerate evidence = + PositiveDefiniteIsNondegenerate evidence + +public export +positive_definite_is_anisotropic : + {space : FiniteSpace} -> + {form : QuadraticForm space} -> + PositiveDefinite form -> + Anisotropic form +positive_definite_is_anisotropic evidence = + PositiveDefiniteIsAnisotropic evidence + +public export +positive_definite_is_semidefinite : + {space : FiniteSpace} -> + {form : QuadraticForm space} -> + PositiveDefinite form -> + PositiveSemidefinite form +positive_definite_is_semidefinite evidence = + PositiveDefiniteIsSemidefinite evidence + +public export +complex_x : ExactComplexCovectorSample planeSpace +complex_x = complex_plane_covector complex_one complex_zero + +public export +complex_y : ExactComplexCovectorSample planeSpace +complex_y = complex_plane_covector complex_zero complex_one + +public export +plane_standard_hermitian : HermitianForm planeSpace +plane_standard_hermitian = + HermitianSum (HermitianSquare complex_x) (HermitianSquare complex_y) + +public export +data HermitianPositiveDefinite : + {space : FiniteSpace} -> HermitianForm space -> Type where + StandardComplexPlanePositive : + HermitianPositiveDefinite plane_standard_hermitian + +public export +data HermitianNondegenerate : + {space : FiniteSpace} -> HermitianForm space -> Type where + HermitianPositiveIsNondegenerate : + {form : HermitianForm space} -> + HermitianPositiveDefinite form -> + HermitianNondegenerate form + +public export +hermitian_positive_is_nondegenerate : + {space : FiniteSpace} -> + {form : HermitianForm space} -> + HermitianPositiveDefinite form -> + HermitianNondegenerate form +hermitian_positive_is_nondegenerate evidence = + HermitianPositiveIsNondegenerate evidence + +-- -------------------------------------------------------------------------- +-- Basis-dependent 2D matrix representations +-- -------------------------------------------------------------------------- + +-- The repository does not yet have a general basis or mathematical Matrix +-- ontology. This contained plane slice establishes the correct abstraction +-- boundary without presenting a rectangular array as the definition of a form. + +public export +data IntegerMatrix2 = Matrix2 Integer Integer Integer Integer + +public export +data SymmetricIntegerMatrix2 = SymmetricMatrix2 Integer Integer Integer + +public export +full_symmetric_matrix : SymmetricIntegerMatrix2 -> IntegerMatrix2 +full_symmetric_matrix (SymmetricMatrix2 first off_diagonal second) = + Matrix2 first off_diagonal off_diagonal second + +public export +transpose_integer_matrix : IntegerMatrix2 -> IntegerMatrix2 +transpose_integer_matrix (Matrix2 a b c d) = Matrix2 a c b d + +public export +multiply_integer_matrix : IntegerMatrix2 -> IntegerMatrix2 -> IntegerMatrix2 +multiply_integer_matrix + (Matrix2 a b c d) + (Matrix2 e f g h) = + Matrix2 + (a * e + b * g) + (a * f + b * h) + (c * e + d * g) + (c * f + d * h) + +public export +data PlaneBasis = StandardPlaneBasis | ShearedPlaneBasis + +public export +basis_first : PlaneBasis -> ExactVectorSample planeSpace +basis_first StandardPlaneBasis = planeVector 1 0 +basis_first ShearedPlaneBasis = planeVector 1 0 + +public export +basis_second : PlaneBasis -> ExactVectorSample planeSpace +basis_second StandardPlaneBasis = planeVector 0 1 +basis_second ShearedPlaneBasis = planeVector 1 1 + +basis_dual_first : PlaneBasis -> ExactCovectorSample planeSpace +basis_dual_first StandardPlaneBasis = planeCovector 1 0 +basis_dual_first ShearedPlaneBasis = planeCovector 1 (-1) + +basis_dual_second : PlaneBasis -> ExactCovectorSample planeSpace +basis_dual_second StandardPlaneBasis = planeCovector 0 1 +basis_dual_second ShearedPlaneBasis = planeCovector 0 1 + +public export +data GramMatrix : PlaneBasis -> Type where + Gram : (basis : PlaneBasis) -> SymmetricIntegerMatrix2 -> GramMatrix basis + +public export +gram_entries : {basis : PlaneBasis} -> GramMatrix basis -> SymmetricIntegerMatrix2 +gram_entries (Gram basis matrix) = matrix + +public export +gram_matrix : + SymmetricBilinearForm planeSpace -> + (basis : PlaneBasis) -> + GramMatrix basis +gram_matrix form basis = + Gram basis + (SymmetricMatrix2 + (evaluate_symmetric form (basis_first basis) (basis_first basis)) + (evaluate_symmetric form (basis_first basis) (basis_second basis)) + (evaluate_symmetric form (basis_second basis) (basis_second basis))) + +public export +represented_symmetric_form : + {basis : PlaneBasis} -> + GramMatrix basis -> + SymmetricBilinearForm planeSpace +represented_symmetric_form (Gram basis (SymmetricMatrix2 first off_diagonal second)) = + SymmetricSum + (SymmetricScale first (SymmetricSquare (basis_dual_first basis))) + (SymmetricSum + (SymmetricScale off_diagonal + (SymmetricPair (basis_dual_first basis) (basis_dual_second basis))) + (SymmetricScale second (SymmetricSquare (basis_dual_second basis)))) + +public export +represented_quadratic_form : + {basis : PlaneBasis} -> + GramMatrix basis -> + QuadraticForm planeSpace +represented_quadratic_form gram = + quadratic_from_symmetric (represented_symmetric_form gram) + +public export +basis_change_matrix : PlaneBasis -> PlaneBasis -> IntegerMatrix2 +basis_change_matrix StandardPlaneBasis StandardPlaneBasis = Matrix2 1 0 0 1 +basis_change_matrix StandardPlaneBasis ShearedPlaneBasis = Matrix2 1 1 0 1 +basis_change_matrix ShearedPlaneBasis StandardPlaneBasis = Matrix2 1 (-1) 0 1 +basis_change_matrix ShearedPlaneBasis ShearedPlaneBasis = Matrix2 1 0 0 1 + +public export +congruence_from : + {old_basis : PlaneBasis} -> + GramMatrix old_basis -> + (new_basis : PlaneBasis) -> + IntegerMatrix2 +congruence_from (Gram old_basis matrix) new_basis = + let change = basis_change_matrix old_basis new_basis + left = multiply_integer_matrix + (transpose_integer_matrix change) + (full_symmetric_matrix matrix) + in multiply_integer_matrix left change + +public export +plane_weighted_symmetric : SymmetricBilinearForm planeSpace +plane_weighted_symmetric = + SymmetricSum + (SymmetricScale 2 (SymmetricSquare plane_x)) + (SymmetricScale 3 (SymmetricSquare plane_y)) + +public export +plane_weighted_quadratic : QuadraticForm planeSpace +plane_weighted_quadratic = quadratic_from_symmetric plane_weighted_symmetric + +-- -------------------------------------------------------------------------- +-- Basis-dependent Hermitian matrices +-- -------------------------------------------------------------------------- + +public export +data ExactComplexMatrix2 = + ComplexMatrix2 ExactComplex ExactComplex ExactComplex ExactComplex + +public export +data HermitianMatrix2 = HermitianMatrix2 Integer ExactComplex Integer + +public export +full_hermitian_matrix : HermitianMatrix2 -> ExactComplexMatrix2 +full_hermitian_matrix (HermitianMatrix2 first off_diagonal second) = + ComplexMatrix2 + (Complex first 0) + off_diagonal + (conjugate off_diagonal) + (Complex second 0) + +public export +transpose_complex_matrix : ExactComplexMatrix2 -> ExactComplexMatrix2 +transpose_complex_matrix (ComplexMatrix2 a b c d) = ComplexMatrix2 a c b d + +public export +conjugate_transpose_complex_matrix : ExactComplexMatrix2 -> ExactComplexMatrix2 +conjugate_transpose_complex_matrix (ComplexMatrix2 a b c d) = + ComplexMatrix2 (conjugate a) (conjugate c) (conjugate b) (conjugate d) + +public export +multiply_complex_matrix : + ExactComplexMatrix2 -> ExactComplexMatrix2 -> ExactComplexMatrix2 +multiply_complex_matrix + (ComplexMatrix2 a b c d) + (ComplexMatrix2 e f g h) = + ComplexMatrix2 + (complex_add (complex_multiply a e) (complex_multiply b g)) + (complex_add (complex_multiply a f) (complex_multiply b h)) + (complex_add (complex_multiply c e) (complex_multiply d g)) + (complex_add (complex_multiply c f) (complex_multiply d h)) + +public export +data ComplexPlaneBasis = StandardComplexBasis | ComplexShearedBasis + +public export +complex_basis_first : ComplexPlaneBasis -> ExactComplexVectorSample planeSpace +complex_basis_first StandardComplexBasis = + complex_plane_vector complex_one complex_zero +complex_basis_first ComplexShearedBasis = + complex_plane_vector complex_one complex_zero + +public export +complex_basis_second : ComplexPlaneBasis -> ExactComplexVectorSample planeSpace +complex_basis_second StandardComplexBasis = + complex_plane_vector complex_zero complex_one +complex_basis_second ComplexShearedBasis = + complex_plane_vector complex_i complex_one + +complex_basis_dual_first : + ComplexPlaneBasis -> ExactComplexCovectorSample planeSpace +complex_basis_dual_first StandardComplexBasis = + complex_plane_covector complex_one complex_zero +complex_basis_dual_first ComplexShearedBasis = + complex_plane_covector complex_one (Complex 0 (-1)) + +complex_basis_dual_second : + ComplexPlaneBasis -> ExactComplexCovectorSample planeSpace +complex_basis_dual_second StandardComplexBasis = + complex_plane_covector complex_zero complex_one +complex_basis_dual_second ComplexShearedBasis = + complex_plane_covector complex_zero complex_one + +public export +data HermitianGramMatrix : ComplexPlaneBasis -> Type where + HermitianGram : + (basis : ComplexPlaneBasis) -> + HermitianMatrix2 -> + HermitianGramMatrix basis + +public export +hermitian_gram_entries : + {basis : ComplexPlaneBasis} -> + HermitianGramMatrix basis -> + HermitianMatrix2 +hermitian_gram_entries (HermitianGram basis matrix) = matrix + +public export +hermitian_gram_matrix : + HermitianForm planeSpace -> + (basis : ComplexPlaneBasis) -> + HermitianGramMatrix basis +hermitian_gram_matrix form basis = + HermitianGram basis + (HermitianMatrix2 + (real_part + (evaluate_hermitian form + (complex_basis_first basis) + (complex_basis_first basis))) + (evaluate_hermitian form + (complex_basis_first basis) + (complex_basis_second basis)) + (real_part + (evaluate_hermitian form + (complex_basis_second basis) + (complex_basis_second basis)))) + +public export +represented_hermitian_form : + {basis : ComplexPlaneBasis} -> + HermitianGramMatrix basis -> + HermitianForm planeSpace +represented_hermitian_form + (HermitianGram basis (HermitianMatrix2 first off_diagonal second)) = + HermitianSum + (HermitianScale first (HermitianSquare (complex_basis_dual_first basis))) + (HermitianSum + (HermitianCross + off_diagonal + (complex_basis_dual_first basis) + (complex_basis_dual_second basis)) + (HermitianScale second + (HermitianSquare (complex_basis_dual_second basis)))) + +public export +complex_basis_change_matrix : + ComplexPlaneBasis -> ComplexPlaneBasis -> ExactComplexMatrix2 +complex_basis_change_matrix StandardComplexBasis StandardComplexBasis = + ComplexMatrix2 complex_one complex_zero complex_zero complex_one +complex_basis_change_matrix StandardComplexBasis ComplexShearedBasis = + ComplexMatrix2 complex_one complex_i complex_zero complex_one +complex_basis_change_matrix ComplexShearedBasis StandardComplexBasis = + ComplexMatrix2 complex_one (Complex 0 (-1)) complex_zero complex_one +complex_basis_change_matrix ComplexShearedBasis ComplexShearedBasis = + ComplexMatrix2 complex_one complex_zero complex_zero complex_one + +public export +hermitian_congruence_from : + {old_basis : ComplexPlaneBasis} -> + HermitianGramMatrix old_basis -> + (new_basis : ComplexPlaneBasis) -> + ExactComplexMatrix2 +hermitian_congruence_from (HermitianGram old_basis matrix) new_basis = + let change = complex_basis_change_matrix old_basis new_basis + left = multiply_complex_matrix + (conjugate_transpose_complex_matrix change) + (full_hermitian_matrix matrix) + in multiply_complex_matrix left change + +-- This operation is intentionally present only as an acceptance oracle showing +-- why ordinary transpose is wrong for complex Hermitian change of basis. +public export +ordinary_transpose_congruence_oracle : + {old_basis : ComplexPlaneBasis} -> + HermitianGramMatrix old_basis -> + (new_basis : ComplexPlaneBasis) -> + ExactComplexMatrix2 +ordinary_transpose_congruence_oracle + (HermitianGram old_basis matrix) + new_basis = + let change = complex_basis_change_matrix old_basis new_basis + left = multiply_complex_matrix + (transpose_complex_matrix change) + (full_hermitian_matrix matrix) + in multiply_complex_matrix left change + +-- -------------------------------------------------------------------------- +-- Characteristic-2 acceptance model +-- -------------------------------------------------------------------------- + +-- The current vector sample uses Integer scalars, but this tiny F2 model keeps +-- a real characteristic-2 counterexample in the compiler acceptance suite. +-- q(x,y)=xy is nonzero while the diagonal of its polar form is always zero. + +public export +data F2 = F2Zero | F2One + +f2_add : F2 -> F2 -> F2 +f2_add F2Zero value = value +f2_add value F2Zero = value +f2_add F2One F2One = F2Zero + +f2_multiply : F2 -> F2 -> F2 +f2_multiply F2Zero value = F2Zero +f2_multiply value F2Zero = F2Zero +f2_multiply F2One F2One = F2One + +public export +data F2Plane = F2Vector F2 F2 + +f2_vector_add : F2Plane -> F2Plane -> F2Plane +f2_vector_add (F2Vector a b) (F2Vector c d) = + F2Vector (f2_add a c) (f2_add b d) + +public export +f2_cross_quadratic : F2Plane -> F2 +f2_cross_quadratic (F2Vector x y) = f2_multiply x y + +public export +f2_polar : F2Plane -> F2Plane -> F2 +f2_polar left right = + f2_add + (f2_cross_quadratic (f2_vector_add left right)) + (f2_add (f2_cross_quadratic left) (f2_cross_quadratic right)) From da943cec8fd3884160c57248d10e30bf8cf921bf Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:30:49 -0400 Subject: [PATCH 42/80] Add compiler-checked form semantics acceptance tests --- .../FormTests.idric | 318 ++++++++++++++++++ 1 file changed, 318 insertions(+) create mode 100644 _/examples/unified-higher-mathematics/FormTests.idric diff --git a/_/examples/unified-higher-mathematics/FormTests.idric b/_/examples/unified-higher-mathematics/FormTests.idric new file mode 100644 index 0000000000..ebd7c60203 --- /dev/null +++ b/_/examples/unified-higher-mathematics/FormTests.idric @@ -0,0 +1,318 @@ +module FormTests + +import MathematicalSpaces +import QuadraticForms + +%default total +%unbound_implicits off + +-- -------------------------------------------------------------------------- +-- Abstract forms and quadratic/polar distinction +-- -------------------------------------------------------------------------- + +bilinear_evaluation_test : + evaluate_bilinear + (BilinearTensor plane_x plane_y) + (planeVector 3 4) + (planeVector 5 7) = 21 +bilinear_evaluation_test = Refl + +bilinear_to_dual_test : + contract + (bilinear_covector_at + (BilinearTensor plane_x plane_y) + (planeVector 3 4)) + (planeVector 5 7) = 21 +bilinear_to_dual_test = Refl + +quadratic_evaluation_test : + evaluate_quadratic plane_positive_quadratic (planeVector 3 4) = 25 +quadratic_evaluation_test = Refl + +primitive_cross_term_test : + evaluate_quadratic plane_cross_quadratic (planeVector 3 4) = 12 +primitive_cross_term_test = Refl + +polar_cross_term_test : + evaluate_symmetric + (polar_form plane_cross_quadratic) + (planeVector 1 0) + (planeVector 0 1) = 1 +polar_cross_term_test = Refl + +polar_difference_test : + polar_difference + plane_cross_quadratic + (planeVector 1 0) + (planeVector 0 1) = 1 +polar_difference_test = Refl + +-- q(x,y)=xy is not identified with the diagonal of its unhalved polar form. +-- At (1,1), q=1 while polar(q)(v,v)=2 over the exact integral model. +quadratic_diagonal_value_test : + evaluate_quadratic plane_cross_quadratic (planeVector 1 1) = 1 +quadratic_diagonal_value_test = Refl + +polar_diagonal_value_test : + evaluate_symmetric + (polar_form plane_cross_quadratic) + (planeVector 1 1) + (planeVector 1 1) = 2 +polar_diagonal_value_test = Refl + +positive_diagonal_presentation : + DiagonalPresentation plane_positive_quadratic +positive_diagonal_presentation = + SumHasDiagonalPresentation + (SquareHasDiagonalPresentation plane_x) + (SquareHasDiagonalPresentation plane_y) + +failing "Mismatch between" + odd_cross_term_has_no_square_presentation : + DiagonalPresentation plane_cross_quadratic + odd_cross_term_has_no_square_presentation = + SquareHasDiagonalPresentation plane_x + +-- -------------------------------------------------------------------------- +-- Refinements are evidence, not Boolean metadata +-- -------------------------------------------------------------------------- + +positive_definite_evidence : PositiveDefinite plane_positive_quadratic +positive_definite_evidence = PlaneSumOfSquaresPositive + +positive_semidefinite_from_definite : + PositiveSemidefinite plane_positive_quadratic +positive_semidefinite_from_definite = + positive_definite_is_semidefinite positive_definite_evidence + +positive_nondegenerate_from_definite : + QuadraticNondegenerate plane_positive_quadratic +positive_nondegenerate_from_definite = + positive_definite_is_nondegenerate positive_definite_evidence + +positive_anisotropic_from_definite : Anisotropic plane_positive_quadratic +positive_anisotropic_from_definite = + positive_definite_is_anisotropic positive_definite_evidence + +negative_definite_evidence : NegativeDefinite plane_negative_quadratic +negative_definite_evidence = NegativePlaneSumOfSquares + +semidefinite_evidence : PositiveSemidefinite plane_first_square +semidefinite_evidence = PlaneFirstSquareSemidefinite + +degenerate_evidence : QuadraticDegenerate plane_first_square +degenerate_evidence = PlaneFirstSquareDegenerate + +indefinite_evidence : Indefinite plane_difference_of_squares +indefinite_evidence = PlaneDifferenceOfSquaresIndefinite + +isotropic_evidence : Isotropic plane_difference_of_squares +isotropic_evidence = PlaneDifferenceOfSquaresIsotropic + +integral_evidence : IntegralQuadratic plane_positive_quadratic +integral_evidence = ExactIntegerValued plane_positive_quadratic + +even_evidence : EvenQuadratic (QuadraticScale 2 plane_positive_quadratic) +even_evidence = TwiceIntegralFormIsEven plane_positive_quadratic + +indefinite_positive_witness_test : + evaluate_quadratic plane_difference_of_squares (planeVector 2 1) = 3 +indefinite_positive_witness_test = Refl + +indefinite_negative_witness_test : + evaluate_quadratic plane_difference_of_squares (planeVector 1 2) = -3 +indefinite_negative_witness_test = Refl + +isotropic_witness_test : + evaluate_quadratic plane_difference_of_squares (planeVector 1 1) = 0 +isotropic_witness_test = Refl + +degenerate_direction_test : + evaluate_quadratic plane_first_square (planeVector 0 1) = 0 +degenerate_direction_test = Refl + +-- -------------------------------------------------------------------------- +-- Hermitian and sesquilinear semantics +-- -------------------------------------------------------------------------- + +complex_left : ExactComplexVectorSample planeSpace +complex_left = complex_plane_vector (Complex 1 1) complex_zero + +complex_right : ExactComplexVectorSample planeSpace +complex_right = complex_plane_vector complex_one complex_zero + +hermitian_conjugates_first_argument_test : + evaluate_hermitian + plane_standard_hermitian + complex_left + complex_right = Complex 1 (-1) +hermitian_conjugates_first_argument_test = Refl + +hermitian_symmetry_sample_test : + evaluate_hermitian + plane_standard_hermitian + complex_left + complex_right + = conjugate + (evaluate_hermitian + plane_standard_hermitian + complex_right + complex_left) +hermitian_symmetry_sample_test = Refl + +sesquilinear_view_test : + evaluate_sesquilinear + (hermitian_as_sesquilinear plane_standard_hermitian) + complex_left + complex_right = Complex 1 (-1) +sesquilinear_view_test = Refl + +hermitian_quadratic_quantity_test : + hermitian_quadratic_quantity + plane_standard_hermitian + (complex_plane_vector (Complex 1 1) (Complex 2 (-1))) = 7 +hermitian_quadratic_quantity_test = Refl + +hermitian_to_dual_test : + complex_contract + (hermitian_covector_at plane_standard_hermitian complex_left) + complex_right = Complex 1 (-1) +hermitian_to_dual_test = Refl + +hermitian_positive_evidence : + HermitianPositiveDefinite plane_standard_hermitian +hermitian_positive_evidence = StandardComplexPlanePositive + +hermitian_nondegenerate_evidence : + HermitianNondegenerate plane_standard_hermitian +hermitian_nondegenerate_evidence = + hermitian_positive_is_nondegenerate hermitian_positive_evidence + +failing "Mismatch between" + ordinary_vector_is_not_complex_vector : ExactComplex + ordinary_vector_is_not_complex_vector = + evaluate_hermitian + plane_standard_hermitian + (planeVector 1 0) + (planeVector 0 1) + +-- -------------------------------------------------------------------------- +-- Basis-dependent Gram representations +-- -------------------------------------------------------------------------- + +standard_weighted_gram : GramMatrix StandardPlaneBasis +standard_weighted_gram = gram_matrix plane_weighted_symmetric StandardPlaneBasis + +sheared_weighted_gram : GramMatrix ShearedPlaneBasis +sheared_weighted_gram = gram_matrix plane_weighted_symmetric ShearedPlaneBasis + +standard_gram_entries_test : + gram_entries standard_weighted_gram = SymmetricMatrix2 2 0 3 +standard_gram_entries_test = Refl + +sheared_gram_entries_test : + gram_entries sheared_weighted_gram = SymmetricMatrix2 2 2 5 +sheared_gram_entries_test = Refl + +ordinary_congruence_law_test : + congruence_from standard_weighted_gram ShearedPlaneBasis = + Matrix2 2 2 2 5 +ordinary_congruence_law_test = Refl + +basis_independent_value_from_standard_gram_test : + evaluate_quadratic + (represented_quadratic_form standard_weighted_gram) + (planeVector 2 1) = 11 +basis_independent_value_from_standard_gram_test = Refl + +basis_independent_value_from_sheared_gram_test : + evaluate_quadratic + (represented_quadratic_form sheared_weighted_gram) + (planeVector 2 1) = 11 +basis_independent_value_from_sheared_gram_test = Refl + +underlying_form_value_test : + evaluate_quadratic plane_weighted_quadratic (planeVector 2 1) = 11 +underlying_form_value_test = Refl + +failing "Mismatch between" + gram_matrix_remembers_its_basis : GramMatrix StandardPlaneBasis + gram_matrix_remembers_its_basis = sheared_weighted_gram + +-- -------------------------------------------------------------------------- +-- Hermitian change of basis: P* G P, not P^T G P +-- -------------------------------------------------------------------------- + +standard_hermitian_gram : HermitianGramMatrix StandardComplexBasis +standard_hermitian_gram = + hermitian_gram_matrix plane_standard_hermitian StandardComplexBasis + +sheared_hermitian_gram : HermitianGramMatrix ComplexShearedBasis +sheared_hermitian_gram = + hermitian_gram_matrix plane_standard_hermitian ComplexShearedBasis + +standard_hermitian_gram_test : + hermitian_gram_entries standard_hermitian_gram = + HermitianMatrix2 1 complex_zero 1 +standard_hermitian_gram_test = Refl + +sheared_hermitian_gram_test : + hermitian_gram_entries sheared_hermitian_gram = + HermitianMatrix2 1 complex_i 2 +sheared_hermitian_gram_test = Refl + +conjugate_transpose_change_of_basis_test : + hermitian_congruence_from standard_hermitian_gram ComplexShearedBasis = + ComplexMatrix2 + complex_one + complex_i + (Complex 0 (-1)) + (Complex 2 0) +conjugate_transpose_change_of_basis_test = Refl + +ordinary_transpose_is_different_test : + ordinary_transpose_congruence_oracle + standard_hermitian_gram + ComplexShearedBasis = + ComplexMatrix2 + complex_one + complex_i + complex_i + complex_zero +ordinary_transpose_is_different_test = Refl + +hermitian_basis_independent_standard_value_test : + hermitian_quadratic_quantity + (represented_hermitian_form standard_hermitian_gram) + (complex_plane_vector (Complex 1 1) (Complex 2 (-1))) = 7 +hermitian_basis_independent_standard_value_test = Refl + +hermitian_basis_independent_sheared_value_test : + hermitian_quadratic_quantity + (represented_hermitian_form sheared_hermitian_gram) + (complex_plane_vector (Complex 1 1) (Complex 2 (-1))) = 7 +hermitian_basis_independent_sheared_value_test = Refl + +-- -------------------------------------------------------------------------- +-- Characteristic 2: quadratic and symmetric-bilinear data are not equivalent +-- -------------------------------------------------------------------------- + +f2_nonzero_quadratic_test : + f2_cross_quadratic (F2Vector F2One F2One) = F2One +f2_nonzero_quadratic_test = Refl + +f2_polar_diagonal_vanishes_test : + f2_polar + (F2Vector F2One F2One) + (F2Vector F2One F2One) = F2Zero +f2_polar_diagonal_vanishes_test = Refl + +f2_polar_cross_term_test : + f2_polar + (F2Vector F2One F2Zero) + (F2Vector F2Zero F2One) = F2One +f2_polar_cross_term_test = Refl + +main : IO () +main = do + putStrLn "quadratic and Hermitian form semantics: PASS" From 901b4cb753e2322114fe06819213678bfc2bfcd9 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:31:03 -0400 Subject: [PATCH 43/80] Run quadratic and Hermitian form acceptance tests --- _/tests/idris2/basic/edric009/run | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/_/tests/idris2/basic/edric009/run b/_/tests/idris2/basic/edric009/run index 474e43be1d..99b561e670 100755 --- a/_/tests/idris2/basic/edric009/run +++ b/_/tests/idris2/basic/edric009/run @@ -12,7 +12,9 @@ cp "$example_dir/EuclideanGeometry.idric" "$fixture_dir/EuclideanGeometry.idric" cp "$example_dir/TopologyFacts.idric" "$fixture_dir/TopologyFacts.idric" cp "$example_dir/PresheafRestriction.idric" "$fixture_dir/PresheafRestriction.idric" cp "$example_dir/NamedFacts.idric" "$fixture_dir/NamedFacts.idric" +cp "$example_dir/QuadraticForms.idric" "$fixture_dir/QuadraticForms.idric" cp "$example_dir/Tests.idric" "$fixture_dir/Tests.idric" +cp "$example_dir/FormTests.idric" "$fixture_dir/FormTests.idric" # Preserve .idric all the way into the bootstrapped compiler. The previous # geometry runner renamed its sources to .idr; this receipt exercises the @@ -31,4 +33,16 @@ cp "$example_dir/Tests.idric" "$fixture_dir/Tests.idric" fi ./build/exec/unified-higher-mathematics + + if ! "$idris2" --check FormTests.idric >form-typecheck.log 2>&1; then + cat form-typecheck.log >&2 + exit 1 + fi + + if ! "$idris2" FormTests.idric -o quadratic-hermitian-forms >form-build.log 2>&1; then + cat form-build.log >&2 + exit 1 + fi + + ./build/exec/quadratic-hermitian-forms ) From 50ea445ba2652316109c614bdc8bd4403174d309 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:31:10 -0400 Subject: [PATCH 44/80] Record quadratic and Hermitian form acceptance receipt --- _/tests/idris2/basic/edric009/expected | 1 + 1 file changed, 1 insertion(+) diff --git a/_/tests/idris2/basic/edric009/expected b/_/tests/idris2/basic/edric009/expected index 3b24608c0d..69ef4d8eb3 100644 --- a/_/tests/idris2/basic/edric009/expected +++ b/_/tests/idris2/basic/edric009/expected @@ -3,3 +3,4 @@ R^128 exact orthogonal oracle: PASS invalid contractions rejected by the compiler: PASS finite presheaf restriction laws: PASS provenance-aware named fact lookup: PASS +quadratic and Hermitian form semantics: PASS From 7b177f098d29eac4cfa28e6653ec3d31d3ac59de Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:32:08 -0400 Subject: [PATCH 45/80] Document quadratic and Hermitian form architecture --- .../QUADRATIC-FORMS.md | 222 ++++++++++++++++++ 1 file changed, 222 insertions(+) create mode 100644 _/examples/unified-higher-mathematics/QUADRATIC-FORMS.md diff --git a/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md b/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md new file mode 100644 index 0000000000..253a2d9707 --- /dev/null +++ b/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md @@ -0,0 +1,222 @@ +# Quadratic and Hermitian forms + +This note records the abstraction boundary exercised by `QuadraticForms.idric` and +`FormTests.idric`. + +The central rule is: + +> A form is a mathematical object. A matrix is a representation of that form +> relative to a chosen basis. + +The implementation deliberately does not define a quadratic form as a symmetric +matrix, and it does not treat a Hermitian expression `d* G d` as an ordinary +complex quadratic form. + +## Existing Idriç linear-algebra inventory + +The current canonical branch already has one useful programmer-facing semantic +core in `unified-higher-mathematics`: + +- `FiniteSpace` distinguishes named finite spaces, not merely dimensions. +- `ExactVectorSample space` and `ExactCovectorSample space` are distinct types. +- `contract` evaluates a covector on a vector and requires the same named space. +- `EuclideanStructure space` is explicit; lowering/raising indices and `dot` + require it. There is no metric-free vector-to-covector coercion. +- `IndexedValue` tracks upper/lower variance for the first checked contraction + experiment. + +The repository also contains inherited Idris machinery that should not be +mistaken for this ontology: + +- `_/libs/linear` concerns linear *usage* (`Data.Linear`, `LIO`, `LVect`), not + mathematical linear algebra. +- `Data.IOMatrix` is an implementation data structure, not a basis-aware + representation of a linear map or form. +- the root `Algebra.Semiring` abstraction currently records operations and + neutral elements, but not the law-bearing ring/field/module/ordered-field or + involution structure required for a general forms library. + +There is not yet a mature programmer-facing general `Basis`, mathematical +`Matrix`, complex scalar, scalar field, module, linear map, or linear +isomorphism ontology on the canonical branch. The previous higher-mathematics +README explicitly deferred multiple bases, indefinite bilinear forms, arbitrary +matrix certification, and scalar-field abstraction. + +That is the architectural limit for this patch. It extends the compiler-checked +semantic experiment rather than silently upgrading inherited Idris containers +into mathematical objects. + +## Abstract form types + +`QuadraticForms.idric` introduces separate types for: + +- `BilinearForm V`: structurally bilinear combinations of covector tensors; +- `SymmetricBilinearForm V`: structurally symmetric bilinear combinations; +- `QuadraticForm V`: a primitive quadratic type, including cross terms that do + not have to be presented as diagonals of integral symmetric bilinear forms; +- `SesquilinearForm V`: conjugate-linear in the first argument and linear in + the second; +- `HermitianForm V`: a closed Hermitian construction whose cross terms include + their conjugate partner. + +The ordinary executable sample continues to use exact integer vectors. This is +not a claim that `Integer` is the scalar field of the named real spaces. It is a +small exact lattice model consistent with the existing higher-mathematics +slice. + +The complex executable sample uses exact Gaussian-integer coordinates. It adds +separate complex vectors and covectors rather than reinterpreting ordinary +integer vectors. + +## Quadratic form versus bilinear form + +For a symmetric bilinear form `B`, `quadratic_from_symmetric B` is always valid: + +`q(v) = B(v,v)`. + +The reverse direction is deliberately not an unconditional equivalence. +`polar_form q` is the integral, unhalved polar form + +`q(x+y) - q(x) - q(y)`. + +For `q(v)=B(v,v)`, this is `2B` in the present exact integral model. A +`DiagonalPresentation q` is separate evidence that a particular integral +quadratic form is known to have an integral symmetric diagonal presentation. +There is no generic constructor for an odd product term `alpha(v) beta(v)`, +because its symmetric presentation would require division by two. + +This leaves the type boundary correct for future characteristic-2 scalars. +`FormTests.idric` also contains an explicit two-dimensional F2 example: +`q(x,y)=xy` is nonzero, while the diagonal of its polar form vanishes. Thus the +acceptance suite cannot regress to a universal quadratic/symmetric-bilinear +identification. + +## Hermitian versus ordinary complex quadratic structure + +The convention in this module is: + +- conjugate-linear in the first argument; +- linear in the second. + +A Hermitian form satisfies the intended structural law + +`H(x,y) = conjugate(H(y,x))`. + +`hermitian_quadratic_quantity H v` exposes the real diagonal quantity `H(v,v)` +in the exact Gaussian-integer model. It does not coerce the Hermitian form into +an ordinary `QuadraticForm`. + +Fixing the first argument of a Hermitian form yields a complex covector in the +second argument. As a map from the first vector to the dual, this lowering is +conjugate-linear. The patch therefore does not copy the real-vector lowering +rule mechanically. + +## Refinements now represented + +The current exact quadratic sample has evidence types for: + +- positive definite; +- negative definite; +- positive semidefinite; +- negative semidefinite; +- nondegenerate; +- degenerate; +- indefinite; +- isotropic; +- anisotropic; +- integral; +- even. + +The current Hermitian sample has evidence for positive definiteness and +nondegeneracy. + +These are certificates indexed by the form value, not Boolean fields stored in +the form. Properties therefore compose without a nominal wrapper for every +combination: the same form value can carry, for example, positive-definite, +nondegenerate, anisotropic, and integral evidence. The certificate vocabulary +is intentionally small and constructive; it is not presented as a complete +decision procedure for arbitrary forms. + +`positive_definite_is_nondegenerate` and related functions demonstrate that an +operation can require and transform mathematical evidence rather than testing +metadata at runtime. + +## Refinements intentionally deferred + +The following should not be generalized from the current exact sample until the +missing scalar/lattice architecture exists: + +- odd integral forms; +- unimodularity; +- signature and fixed signature; +- general nondegeneracy/radical machinery in characteristic 2; +- decision procedures for definiteness or degeneracy of arbitrary forms; +- real positivity over an ordered field rather than the exact integer sample. + +Unimodularity in particular needs an explicit lattice and basis-independent +statement, not merely `det(matrix) = +/-1` attached to an arbitrary coordinate +array. Signature needs a real/ordered scalar extension with a settled scalar +ontology. + +## Bases and Gram matrices + +Because there is no general `Basis`/`Matrix` ontology yet, this patch adds only +a contained two-dimensional representation slice. + +`GramMatrix basis` is indexed by its chosen `PlaneBasis`. The same symmetric +form therefore yields different matrices in the standard and sheared bases. +The compiler rejects assigning a Gram matrix for one basis to the other basis. +A Gram matrix plus its basis can reconstruct the represented symmetric form, +and evaluating the reconstructed form is independent of which of the two +representations was used. + +The ordinary basis-change acceptance example checks + +`G_B = P^T G_A P`. + +The complex slice similarly uses `HermitianGramMatrix basis` and checks + +`G_B = P* G_A P`, + +where `P*` is conjugate transpose. The same fixture computes the ordinary +transpose result separately and obtains a different, non-Hermitian matrix. This +keeps transpose and conjugate transpose visibly distinct in executable source. + +The local `IntegerMatrix2` and `ExactComplexMatrix2` types are deliberately +representation-level helpers. They are not proposed as the repository's future +general `Matrix` abstraction. + +## Vectors, covectors, and duality + +For bilinear forms, `bilinear_covector_at B x` constructs the covector +`B(x,-)`. For Hermitian forms, `hermitian_covector_at H x` constructs +`H(x,-)`. Both use the existing typed covector layer; neither introduces a +vector-to-covector coercion. + +A nondegenerate form should eventually yield an isomorphism between a vector +space and the appropriate dual (or conjugate-dual structure in the Hermitian +case). The repository does not yet have general linear-map/isomorphism objects +strong enough to express that statement without inventing a one-off wrapper, +so integration stops at the mathematically valid lowering map and indexed +nondegeneracy evidence. + +## Compiler versus library + +No new compiler primitive is required for these forms. The mathematical object +types, closed constructions, refinements, and basis-indexed representations are +library-level code. Existing dependent indices and ordinary equality proofs are +enough for this slice. + +A future generalization should improve the mathematical library layer first: +law-bearing scalar/ring/field and involution structures, modules, bases, linear +maps, duals, and basis-aware matrices. It should not special-case quadratic +forms in the elaborator merely to compensate for those missing abstractions. + +## Conway reading note + +The companion Conway repository already has a chapter guide for John H. +Conway's *The Sensual (Quadratic) Form* in +[Conway PR #6](https://github.com/isomorphismes/Conway/pull/6). That note makes +the same basis-independent form / basis-dependent Gram-matrix distinction and +records the characteristic-2 and Hermitian cautions. This file links to it +rather than duplicating the chapter-by-chapter material. From 61b85d8852f86d584309511ae61195e009f03ad8 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:35:22 -0400 Subject: [PATCH 46/80] Allow inferred space binders in form GADTs --- .../QuadraticForms.idric | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/_/examples/unified-higher-mathematics/QuadraticForms.idric b/_/examples/unified-higher-mathematics/QuadraticForms.idric index 215084dd7f..1a415cf897 100644 --- a/_/examples/unified-higher-mathematics/QuadraticForms.idric +++ b/_/examples/unified-higher-mathematics/QuadraticForms.idric @@ -3,7 +3,6 @@ module QuadraticForms import MathematicalSpaces %default total -%unbound_implicits off -- Forms in this module are mathematical objects. Matrices appear only in the -- representation section, where a chosen basis is part of the type. The @@ -42,6 +41,14 @@ evaluate_bilinear (BilinearSum first second) left right = evaluate_bilinear (BilinearScale scalar form) left right = scalar * evaluate_bilinear form left right +zero_covector : + {space : FiniteSpace} -> + ExactVectorSample space -> + ExactCovectorSample space +zero_covector (UnsafeVectorCoordinates coordinates) = + UnsafeCovectorCoordinates + (unsafeZeroCoordinates (spaceRank space)) + -- Fixing the first argument gives an honest covector, rather than coercing a -- vector into one. This is the currently expressible part of B : V -> V*. public export @@ -60,16 +67,6 @@ bilinear_covector_at (BilinearSum first second) vector = bilinear_covector_at (BilinearScale scalar form) vector = scaleCovector scalar (bilinear_covector_at form vector) --- The zero covector is constructed from the vector's named-space index without --- identifying the vector with its dual. -zero_covector : - {space : FiniteSpace} -> - ExactVectorSample space -> - ExactCovectorSample space -zero_covector (UnsafeVectorCoordinates coordinates) = - UnsafeCovectorCoordinates - (unsafeZeroCoordinates (spaceRank space)) - public export data SymmetricBilinearForm : FiniteSpace -> Type where SymmetricZero : SymmetricBilinearForm space From 9347ccda488234237f8921141d13552a1df954fb Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:39:31 -0400 Subject: [PATCH 47/80] Update higher-math architecture for form semantics --- .../unified-higher-mathematics/README.md | 148 ++++++++++++------ 1 file changed, 100 insertions(+), 48 deletions(-) diff --git a/_/examples/unified-higher-mathematics/README.md b/_/examples/unified-higher-mathematics/README.md index 6977fe06cb..438bf2f123 100644 --- a/_/examples/unified-higher-mathematics/README.md +++ b/_/examples/unified-higher-mathematics/README.md @@ -1,23 +1,24 @@ # Unified higher-mathematics semantics This directory is the conservative reconciliation of the higher-mathematics -experiments in issues and pull requests #42, #45, #46, and #47. It is a -small, compiler-checked semantic example, not a general mathematics library. +experiments in issues and pull requests #42, #45, #46, and #47, extended with +a compiler-checked quadratic/Hermitian-form slice. It is a small semantic +example, not a general mathematics library. ## Established model -`FiniteSpace` carries a nominal `SpaceName` and a known coordinate rank. The +`FiniteSpace` carries a nominal `SpaceName` and a known coordinate rank. The name is itself indexed by its rank, so `PlaneName` cannot be reused at rank -128. The complete `FiniteSpace`, rather than its rank alone, indexes +128. The complete `FiniteSpace`, rather than its rank alone, indexes `ExactVectorSample`, `ExactCovectorSample`, `IndexedValue`, -`EuclideanStructure`, and the orthogonal types. Consequently `planeSpace` +`EuclideanStructure`, and the orthogonal types. Consequently `planeSpace` and `imagePlaneSpace` remain different even though both have rank two. `ExactVectorSample space` and `ExactCovectorSample space` are separate -datatypes. They are explicitly the executable integer-coordinate fragment of +datatypes. They are explicitly the executable integer-coordinate fragment of the named real coordinate space, not its complete carrier and not a claim that -the field of real scalars is `Integer`. Every represented sample nevertheless -denotes a genuine vector or covector. The metric-free operation is covector +the field of real scalars is `Integer`. Every represented sample nevertheless +denotes a genuine vector or covector. The metric-free operation is covector evaluation: ```idris @@ -26,28 +27,28 @@ contract : ExactCovectorSample space -> ExactVectorSample space -> Integer `RawExactCoordinates`, `UnsafeVectorCoordinates`, and the other `unsafe...`/`Unsafe...` names form an explicit representation boundary kept -public for the exact #47 fixture and cross-module normalization. Destructing +public for the exact #47 fixture and cross-module normalization. Destructing and rebuilding through that boundary can deliberately erase a role or name; -it is raw interoperability, not implicit mathematical inference. The checked +it is raw interoperability, not implicit mathematical inference. The checked API never performs such a conversion silently. There is deliberately no checked vector-to-covector conversion in -`MathematicalSpaces`. `EuclideanStructure space` supplies that additional +`MathematicalSpaces`. `EuclideanStructure space` supplies that additional identification through `lowerIndex` and `raiseIndex`; `dot`, `norm`, `distance`, and index raising/lowering on exact samples all require the -structure explicitly. The current witness is the standard coordinate -Euclidean structure. `norm` and `distance` retain an exact symbolic square -root rather than silently choosing floating-point arithmetic. A complete +structure explicitly. The current witness is the standard coordinate +Euclidean structure. `norm` and `distance` retain an exact symbolic square +root rather than silently choosing floating-point arithmetic. A complete real-scalar representation remains deliberately unchosen. `OrthogonalTransform structure orientation` is indexed by the particular -Euclidean structure and by `Preserving` or `Reversing`. Its public +Euclidean structure and by `Preserving` or `Reversing`. Its public constructors are restricted to the settled identity, first-axis reflection, first-plane quarter-turn, exact integral unit-quaternion rotation, and -composition. `applyOrthogonalExact` interprets that same closed syntax on -exact samples; composition means `left (right sample)`. This removes the old -disconnect between marker values and separate generator evaluators. The -orientation indices record the reviewed standard maps; Idric does not derive +composition. `applyOrthogonalExact` interprets that same closed syntax on +exact samples; composition means `left (right sample)`. This removes the old +disconnect between marker values and separate generator evaluators. The +orientation indices record the reviewed standard maps; Idriç does not derive their determinants or a general metric-preservation theorem in this slice. `SpecialOrthogonal structure` contains only orientation-preserving values. Thus the first-axis reflection is orientation-reversing and two reflections @@ -57,15 +58,59 @@ arbitrary user-supplied matrix or represent every quaternionic rotation. The Einstein-style experiment is intentionally only a one-index kernel. `LowerIndex` contains a covector, `UpperIndex` contains a vector, and `contractIndex` accepts opposite variance over the same complete named-space -index. Equal ranks neither erase a name mismatch nor permit same-variance -contraction. A variance change goes through `lowerIndexed` or `raiseIndexed` +index. Equal ranks neither erase a name mismatch nor permit same-variance +contraction. A variance change goes through `lowerIndexed` or `raiseIndexed` and therefore requires a Euclidean structure. -The finite presheaf example remains in `PresheafRestriction.idric`. It shares +## Quadratic and Hermitian forms + +`QuadraticForms.idric` adds forms as mathematical objects above their +coordinate representations: + +- `BilinearForm` and `SymmetricBilinearForm`; +- a distinct primitive `QuadraticForm`, including cross terms that need not be + presented as the diagonal of an integral symmetric bilinear form; +- `SesquilinearForm`, conjugate-linear in its first argument and linear in its + second; +- `HermitianForm`, whose cross terms carry their conjugate partners. + +A symmetric bilinear form can yield a quadratic form by diagonal evaluation, +but the reverse direction is not encoded as an unconditional equivalence. +`polar_form` is the unhalved integral polar form, and a separate +`DiagonalPresentation` certificate records when an integral quadratic form is +known to have an integral symmetric presentation. The acceptance suite also +contains an explicit characteristic-two `F2` example where `q(x,y)=xy` is +nonzero while the diagonal of its polar form vanishes. + +The current exact quadratic sample carries evidence types for positive and +negative definiteness, positive and negative semidefiniteness, +nondegeneracy/degeneracy, indefiniteness, isotropy/anisotropy, integrality, and +evenness. The Hermitian sample carries positive-definite and nondegenerate +evidence. These properties are indexed certificates, not Boolean fields. + +Fixing one argument of a bilinear form produces an actual +`ExactCovectorSample`; fixing the first argument of a Hermitian form produces +an actual complex covector and is conjugate-linear in that argument. No +vector-to-covector coercion is introduced. + +The repository still lacks a general programmer-facing basis/matrix/scalar +ontology, so coordinate integration deliberately stops at a contained +compiler-checked plane example. `GramMatrix basis` and +`HermitianGramMatrix basis` remember the chosen basis in their types. Two +bases produce different matrices for the same underlying form, with the +ordinary law `G' = P^T G P` and Hermitian law `G' = P* G P`. The complex +fixture separately computes the ordinary-transpose result to demonstrate why +it is wrong for Hermitian change of basis. + +See [QUADRATIC-FORMS.md](QUADRATIC-FORMS.md) for the architecture inventory, +refinement boundary, characteristic-two discussion, duality limit, and link to +the Conway repository's *The Sensual (Quadratic) Form* reading note. + +The finite presheaf example remains in `PresheafRestriction.idric`. It shares the strategy of making inclusions and section domains indices, but it does not -depend on Euclidean geometry. It models three opens, their stated +depend on Euclidean geometry. It models three opens, their stated inclusions, restriction identity and composition, and componentwise -restriction of a formal elementary pair. It claims neither a general +restriction of a formal elementary pair. It claims neither a general presheaf interface nor a tensor-product or sheaf construction. `TopologyFacts.idric` preserves the mathematically settled slice of #45: @@ -79,7 +124,7 @@ presheaf interface nor a tensor-product or sheaf construction. - explicit theorem-boundary values for Jordan separation and the one-point compactification of Euclidean R^n. -Those are encoded standard facts. The compiler is not computing general +Those are encoded standard facts. The compiler is not computing general cohomology, constructing quotient spaces, or deriving separation theorems from coordinates. @@ -90,41 +135,43 @@ from coordinates. | Ordinary type unification | Requires the same full `FiniteSpace`; indexed names prevent both equal-rank conflation and one name acquiring conflicting ranks. | It cannot turn equal coordinate counts into space equality or supply a metric. | | Dependent-index normalization | Reduces rank-indexed constructors, literal exact arithmetic, and closed dimension/rank formulas used by `Refl`. | It does not consult named topology facts. | | Structure information | An explicit `EuclideanStructure space` enables lowering, raising, dot products, norms, distances, and the closed O/SO operations on exact samples. | It is not ordinary unification and is not inferred merely from a rank. | -| Algebraic laws | Closed transform syntax, typed witnesses, and focused equalities record norm-one samples, restriction laws, orientation composition, and exact generator oracles. | The example does not certify arbitrary matrices, prove a general norm-preservation theorem, or synthesize transformations. | +| Algebraic laws | Closed transform/form syntax, typed witnesses, and focused equalities record norm-one samples, restriction laws, orientation composition, exact generator oracles, form evaluations, and basis-change laws. | The example does not certify arbitrary matrices, prove a general norm-preservation theorem, or synthesize arbitrary algebraic structures. | | Named fact lookup | `NamedFact` applies a selected entry to an exact typed hypothesis in `TypedContext` and returns a typed `FactAnswer` with declared attribution and a structured named origin. | It performs no search, proves no stored implication, and does not validate or authenticate metadata. | | External/CAS evidence | Historical SymPy and NumPy/SciPy checks plus the retained dependency-free exact script independently corroborate #47; see [HIGH_DIMENSIONAL_VERIFICATION.md](HIGH_DIMENSIONAL_VERIFICATION.md). | External output is neither imported evidence nor a substitute for the current compiler receipt. | The named-fact proof of concept contains one entry, -`topology.jordan-separation@1`. Its typed hypothesis is an embedded circle in +`topology.jordan-separation@1`. Its typed hypothesis is an embedded circle in S^2 and its typed conclusion is the corresponding two-component separation -fact. Here the embedding value is an explicit assumption token; no map or -injectivity property is inferred or checked. A `NamedFact H C` stores -human-declared attribution plus an Idriç function `(h : H) -> C h`. Lookup +fact. Here the embedding value is an explicit assumption token; no map or +injectivity property is inferred or checked. A `NamedFact H C` stores +human-declared attribution plus an Idriç function `(h : H) -> C h`. Lookup explicitly applies that selected entry to `TypedContext H`; the type checker enforces the exact hypothesis type, and the answer says that it came through -named lookup rather than unification. This is the boundary requested by #42 +named lookup rather than unification. This is the boundary requested by #42 and the companion design note `walnut-burgundy/computer-science#56`; it is not a registry search engine, theorem prover, authenticated provenance system, or the downstream symbolic planner of `computer-science#54`. ## Compiler receipt and fixture isolation -The focused receipt is `tests/idris2/basic/edric009`. It copies the six -modules without renaming their `.idric` suffixes, runs the bootstrapped Idric -compiler's `--check` path, builds an executable, and checks its output. The -negative declarations use `failing`, so the receipt also requires the -compiler to reject space conflation, dimension mismatch, same-variance -contraction, and vector-vector contraction without a metric. +The focused receipt is `_/tests/idris2/basic/edric009`. It copies the eight +`.idric` modules used by the two executable acceptance programs without +renaming their suffixes, runs the bootstrapped Idriç compiler's `--check` path, +builds both executables, and checks their output. The negative declarations +use `failing`, so the receipt also requires the compiler to reject space +conflation, dimension mismatch, same-variance contraction, vector-vector +contraction without a metric, incompatible form/vector families, basis-index +mismatch, and an unsupported integral diagonal presentation. Using `edric009` resolves the inherited fixture collision: the #45/#47 and -#46 experiments both used an `edric008` fixture on separate branches. Their -verified behavior is brought into one new fixture rather than choosing one +#46 experiments both used an `edric008` fixture on separate branches. Their +verified behavior is brought into one fixture rather than choosing one branch's fixture and silently discarding the other. Run only this slice with: ```sh -./edric test --only idris2/basic/edric009 +./_/edric test --only idris2/basic/edric009 ``` The exact R^128 oracle and the distinction between primary compiler evidence @@ -134,7 +181,7 @@ and secondary historical checks are recorded in ## Inherited provenance All inherited experiment branches diverged from -`9b0bf7fa8be9483440e6ec0530f3aef3999a8735`. This reconciliation is based on +`9b0bf7fa8be9483440e6ec0530f3aef3999a8735`. This reconciliation is based on the then-current `Idriç` tip `58295f6fb49a823c5c0880568b30cff513d42d7b`; neither historical branch was treated as a replacement compiler line. @@ -146,7 +193,7 @@ treated as a replacement compiler line. | PR #47 | `examples/high-dimensional-orthogonal-tests` | `214ceaffdb38389bef65b8fa63f73f24d66a609e` | Within #47, commit `1ee26112670866dea3f9a679645aa45f898be3d1` -is the crucial strengthening that put a nonzero value in coordinate 128. The +is the crucial strengthening that put a nonzero value in coordinate 128. The unified fixture preserves that oracle rather than replacing it with a smaller or weaker example. @@ -154,13 +201,18 @@ or weaker example. The smallest coherent boundary leaves the following choices open: -- a scalar-field abstraction, complete real-vector carrier, and exact - representation of arbitrary real coordinates; +- a law-bearing scalar/ring/field/module abstraction, complete real-vector + carrier, and exact representation of arbitrary real coordinates; - named spaces whose dimension is unknown, infinite, or learned only at run time (`FiniteSpace` covers the present known-rank slice only); -- multiple bases or multiple nondefinitionally-equal metrics on one named - space, indefinite bilinear forms, arbitrary matrix certification, and a - reusable proof that every closed transform preserves the metric; +- a general `Basis`, mathematical `Matrix`, linear-map, dual-space, and linear + isomorphism ontology beyond the contained two-dimensional form example; +- multiple nondefinitionally-equal metrics on one named space, arbitrary + matrix certification, and a reusable proof that every closed transform + preserves the metric; +- general decision procedures for form nondegeneracy/definiteness, and the + lattice/ordered-field structure required for oddness, unimodularity, + signature, and fixed signature; - a typed action on `UnitSpherePoint`: the exact transform evaluator is connected now, but lifting it to certified sphere samples awaits that reusable norm-preservation proof rather than wrapping an unchecked image; @@ -172,5 +224,5 @@ The smallest coherent boundary leaves the following choices open: symbolic planner. These are semantic extensions, not cleanup required to reconcile the current -experiments. Adding them would require new mathematical choices and new +experiments. Adding them would require new mathematical choices and new focused tests. From 70628760d15589eb9a0e227cff3f4c395ab43bd5 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:41:03 -0400 Subject: [PATCH 48/80] Strengthen form distinction and refinement acceptance --- .../FormTests.idric | 28 ++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/_/examples/unified-higher-mathematics/FormTests.idric b/_/examples/unified-higher-mathematics/FormTests.idric index ebd7c60203..ed4753f77e 100644 --- a/_/examples/unified-higher-mathematics/FormTests.idric +++ b/_/examples/unified-higher-mathematics/FormTests.idric @@ -97,9 +97,27 @@ positive_anisotropic_from_definite = negative_definite_evidence : NegativeDefinite plane_negative_quadratic negative_definite_evidence = NegativePlaneSumOfSquares +negative_semidefinite_from_definite : + NegativeSemidefinite plane_negative_quadratic +negative_semidefinite_from_definite = + NegativeDefiniteIsSemidefinite negative_definite_evidence + +negative_nondegenerate_from_definite : + QuadraticNondegenerate plane_negative_quadratic +negative_nondegenerate_from_definite = + NegativeDefiniteIsNondegenerate negative_definite_evidence + +negative_anisotropic_from_definite : Anisotropic plane_negative_quadratic +negative_anisotropic_from_definite = + NegativeDefiniteIsAnisotropic negative_definite_evidence + semidefinite_evidence : PositiveSemidefinite plane_first_square semidefinite_evidence = PlaneFirstSquareSemidefinite +negative_semidefinite_evidence : + NegativeSemidefinite plane_negative_first_square +negative_semidefinite_evidence = NegativePlaneFirstSquareSemidefinite + degenerate_evidence : QuadraticDegenerate plane_first_square degenerate_evidence = PlaneFirstSquareDegenerate @@ -120,7 +138,7 @@ indefinite_positive_witness_test : indefinite_positive_witness_test = Refl indefinite_negative_witness_test : - evaluate_quadratic plane_difference_of_squares (planeVector 1 2) = -3 + evaluate_quadratic plane_difference_of_squares (planeVector 1 2) = (-3) indefinite_negative_witness_test = Refl isotropic_witness_test : @@ -188,6 +206,14 @@ hermitian_nondegenerate_evidence : hermitian_nondegenerate_evidence = hermitian_positive_is_nondegenerate hermitian_positive_evidence +failing "Mismatch between" + hermitian_form_is_not_ordinary_quadratic : QuadraticForm planeSpace + hermitian_form_is_not_ordinary_quadratic = plane_standard_hermitian + +failing "Mismatch between" + ordinary_quadratic_is_not_hermitian : HermitianForm planeSpace + ordinary_quadratic_is_not_hermitian = plane_positive_quadratic + failing "Mismatch between" ordinary_vector_is_not_complex_vector : ExactComplex ordinary_vector_is_not_complex_vector = From 669e0cab58887e7007b5b8f9f83aec285709df4b Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:46:43 -0400 Subject: [PATCH 49/80] =?UTF-8?q?Restyle=20quadratic=20forms=20on=20curren?= =?UTF-8?q?t=20Idri=C3=A7=20surface?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../QuadraticForms.idric | 1093 ++++++++--------- 1 file changed, 546 insertions(+), 547 deletions(-) diff --git a/_/examples/unified-higher-mathematics/QuadraticForms.idric b/_/examples/unified-higher-mathematics/QuadraticForms.idric index 1a415cf897..59e68a0426 100644 --- a/_/examples/unified-higher-mathematics/QuadraticForms.idric +++ b/_/examples/unified-higher-mathematics/QuadraticForms.idric @@ -2,37 +2,39 @@ module QuadraticForms import MathematicalSpaces -%default total +%unbound_implicits off --- Forms in this module are mathematical objects. Matrices appear only in the --- representation section, where a chosen basis is part of the type. The --- current higher-mathematics slice has exact Integer vector samples rather than --- a general scalar-field/module hierarchy, so the ordinary forms below are an --- exact integral model. QuadraticForm remains a distinct type from --- SymmetricBilinearForm even here: that distinction is required before a --- future scalar abstraction can honestly include characteristic 2. +-- A form is the mathematical object. A matrix appears only after a basis is +-- chosen. The existing higher-mathematics slice has exact integral samples, +-- not a general scalar-field/module hierarchy, so this module states the +-- strongest exact semantics that the current named-space API can support. -- -------------------------------------------------------------------------- -- Bilinear, symmetric bilinear, and quadratic forms -- -------------------------------------------------------------------------- -public export -data BilinearForm : FiniteSpace -> Type where - BilinearZero : BilinearForm space +export +data BilinearForm : FiniteSpace → Type where + BilinearZero : {space : FiniteSpace} → BilinearForm space BilinearTensor : - ExactCovectorSample space -> - ExactCovectorSample space -> + {space : FiniteSpace} → + ExactCovectorSample space → + ExactCovectorSample space → BilinearForm space - BilinearSum : BilinearForm space -> BilinearForm space -> BilinearForm space - BilinearScale : Integer -> BilinearForm space -> BilinearForm space - -public export + BilinearSum : + {space : FiniteSpace} → + BilinearForm space → BilinearForm space → BilinearForm space + BilinearScale : + {space : FiniteSpace} → + ±Number → BilinearForm space → BilinearForm space + +export evaluate_bilinear : - {space : FiniteSpace} -> - BilinearForm space -> - ExactVectorSample space -> - ExactVectorSample space -> - Integer + {space : FiniteSpace} → + BilinearForm space → + ExactVectorSample space → + ExactVectorSample space → + ±Number evaluate_bilinear BilinearZero left right = 0 evaluate_bilinear (BilinearTensor first second) left right = contract first left * contract second right @@ -42,52 +44,58 @@ evaluate_bilinear (BilinearScale scalar form) left right = scalar * evaluate_bilinear form left right zero_covector : - {space : FiniteSpace} -> - ExactVectorSample space -> + {space : FiniteSpace} → + ExactVectorSample space → ExactCovectorSample space -zero_covector (UnsafeVectorCoordinates coordinates) = - UnsafeCovectorCoordinates - (unsafeZeroCoordinates (spaceRank space)) +zero_covector {space} (UnsafeVectorCoordinates coordinates) = + UnsafeCovectorCoordinates $ unsafe_zero_coordinates (space_rank space) --- Fixing the first argument gives an honest covector, rather than coercing a --- vector into one. This is the currently expressible part of B : V -> V*. -public export +-- Fixing the first argument gives B(x,-) as an actual covector. No vector is +-- silently identified with its dual. +export bilinear_covector_at : - {space : FiniteSpace} -> - BilinearForm space -> - ExactVectorSample space -> + {space : FiniteSpace} → + BilinearForm space → + ExactVectorSample space → ExactCovectorSample space -bilinear_covector_at BilinearZero vector = scaleCovector 0 (zero_covector vector) +bilinear_covector_at BilinearZero vector = + scale_covector 0 $ zero_covector vector bilinear_covector_at (BilinearTensor first second) vector = - scaleCovector (contract first vector) second + scale_covector (contract first vector) second bilinear_covector_at (BilinearSum first second) vector = - addCovector + add_covector (bilinear_covector_at first vector) (bilinear_covector_at second vector) bilinear_covector_at (BilinearScale scalar form) vector = - scaleCovector scalar (bilinear_covector_at form vector) - -public export -data SymmetricBilinearForm : FiniteSpace -> Type where - SymmetricZero : SymmetricBilinearForm space - SymmetricSquare : ExactCovectorSample space -> SymmetricBilinearForm space + scale_covector scalar $ bilinear_covector_at form vector + +export +data SymmetricBilinearForm : FiniteSpace → Type where + SymmetricZero : {space : FiniteSpace} → SymmetricBilinearForm space + SymmetricSquare : + {space : FiniteSpace} → + ExactCovectorSample space → SymmetricBilinearForm space SymmetricPair : - ExactCovectorSample space -> - ExactCovectorSample space -> + {space : FiniteSpace} → + ExactCovectorSample space → + ExactCovectorSample space → SymmetricBilinearForm space SymmetricSum : - SymmetricBilinearForm space -> - SymmetricBilinearForm space -> + {space : FiniteSpace} → + SymmetricBilinearForm space → + SymmetricBilinearForm space → SymmetricBilinearForm space - SymmetricScale : Integer -> SymmetricBilinearForm space -> SymmetricBilinearForm space + SymmetricScale : + {space : FiniteSpace} → + ±Number → SymmetricBilinearForm space → SymmetricBilinearForm space -public export +export evaluate_symmetric : - {space : FiniteSpace} -> - SymmetricBilinearForm space -> - ExactVectorSample space -> - ExactVectorSample space -> - Integer + {space : FiniteSpace} → + SymmetricBilinearForm space → + ExactVectorSample space → + ExactVectorSample space → + ±Number evaluate_symmetric SymmetricZero left right = 0 evaluate_symmetric (SymmetricSquare covector) left right = contract covector left * contract covector right @@ -99,10 +107,10 @@ evaluate_symmetric (SymmetricSum first second) left right = evaluate_symmetric (SymmetricScale scalar form) left right = scalar * evaluate_symmetric form left right -public export +export symmetric_as_bilinear : - {space : FiniteSpace} -> - SymmetricBilinearForm space -> + {space : FiniteSpace} → + SymmetricBilinearForm space → BilinearForm space symmetric_as_bilinear SymmetricZero = BilinearZero symmetric_as_bilinear (SymmetricSquare covector) = @@ -112,41 +120,53 @@ symmetric_as_bilinear (SymmetricPair first second) = (BilinearTensor first second) (BilinearTensor second first) symmetric_as_bilinear (SymmetricSum first second) = - BilinearSum (symmetric_as_bilinear first) (symmetric_as_bilinear second) + BilinearSum + (symmetric_as_bilinear first) + (symmetric_as_bilinear second) symmetric_as_bilinear (SymmetricScale scalar form) = - BilinearScale scalar (symmetric_as_bilinear form) + BilinearScale scalar $ symmetric_as_bilinear form -public export +export symmetric_covector_at : - {space : FiniteSpace} -> - SymmetricBilinearForm space -> - ExactVectorSample space -> + {space : FiniteSpace} → + SymmetricBilinearForm space → + ExactVectorSample space → ExactCovectorSample space symmetric_covector_at form vector = bilinear_covector_at (symmetric_as_bilinear form) vector --- QuadraticForm is primitive. In particular QuadraticProduct permits an +-- QuadraticForm is primitive. In particular, QuadraticProduct permits an -- integral cross term q(v)=alpha(v) beta(v) without pretending that it arose --- as the diagonal of an integral symmetric bilinear form. Over scalars where --- 2 is invertible, stronger conversion machinery can be layered on later. -public export -data QuadraticForm : FiniteSpace -> Type where - QuadraticZero : QuadraticForm space - QuadraticSquare : ExactCovectorSample space -> QuadraticForm space +-- as the diagonal of an integral symmetric bilinear form. This distinction is +-- essential before a future scalar abstraction can honestly include +-- characteristic two. +export +data QuadraticForm : FiniteSpace → Type where + QuadraticZero : {space : FiniteSpace} → QuadraticForm space + QuadraticSquare : + {space : FiniteSpace} → + ExactCovectorSample space → QuadraticForm space QuadraticProduct : - ExactCovectorSample space -> - ExactCovectorSample space -> + {space : FiniteSpace} → + ExactCovectorSample space → + ExactCovectorSample space → QuadraticForm space - QuadraticSum : QuadraticForm space -> QuadraticForm space -> QuadraticForm space - QuadraticScale : Integer -> QuadraticForm space -> QuadraticForm space - QuadraticFromSymmetric : SymmetricBilinearForm space -> QuadraticForm space - -public export + QuadraticSum : + {space : FiniteSpace} → + QuadraticForm space → QuadraticForm space → QuadraticForm space + QuadraticScale : + {space : FiniteSpace} → + ±Number → QuadraticForm space → QuadraticForm space + QuadraticFromSymmetric : + {space : FiniteSpace} → + SymmetricBilinearForm space → QuadraticForm space + +export evaluate_quadratic : - {space : FiniteSpace} -> - QuadraticForm space -> - ExactVectorSample space -> - Integer + {space : FiniteSpace} → + QuadraticForm space → + ExactVectorSample space → + ±Number evaluate_quadratic QuadraticZero vector = 0 evaluate_quadratic (QuadraticSquare covector) vector = contract covector vector * contract covector vector @@ -159,76 +179,77 @@ evaluate_quadratic (QuadraticScale scalar form) vector = evaluate_quadratic (QuadraticFromSymmetric form) vector = evaluate_symmetric form vector vector -public export +export quadratic_from_symmetric : - {space : FiniteSpace} -> - SymmetricBilinearForm space -> + {space : FiniteSpace} → + SymmetricBilinearForm space → QuadraticForm space quadratic_from_symmetric = QuadraticFromSymmetric --- The unhalved polar form exists integrally. It is deliberately not exposed --- as an inverse to quadratic_from_symmetric: --- polar(q)(x,y) = q(x+y)-q(x)-q(y) --- and polar(B(v,v)) = 2 B over this exact integral scalar model. -public export +-- This is the unhalved polar form +-- q(x+y) - q(x) - q(y). +-- For q(v)=B(v,v), it is 2B in the present integral sample. It is therefore +-- not advertised as an inverse to quadratic_from_symmetric. +export polar_form : - {space : FiniteSpace} -> - QuadraticForm space -> + {space : FiniteSpace} → + QuadraticForm space → SymmetricBilinearForm space polar_form QuadraticZero = SymmetricZero polar_form (QuadraticSquare covector) = - SymmetricScale 2 (SymmetricSquare covector) -polar_form (QuadraticProduct first second) = - SymmetricPair first second + SymmetricScale 2 $ SymmetricSquare covector +polar_form (QuadraticProduct first second) = SymmetricPair first second polar_form (QuadraticSum first second) = SymmetricSum (polar_form first) (polar_form second) polar_form (QuadraticScale scalar form) = - SymmetricScale scalar (polar_form form) -polar_form (QuadraticFromSymmetric form) = - SymmetricScale 2 form + SymmetricScale scalar $ polar_form form +polar_form (QuadraticFromSymmetric form) = SymmetricScale 2 form -public export +export polar_difference : - {space : FiniteSpace} -> - QuadraticForm space -> - ExactVectorSample space -> - ExactVectorSample space -> - Integer + {space : FiniteSpace} → + QuadraticForm space → + ExactVectorSample space → + ExactVectorSample space → + ±Number polar_difference form left right = - evaluate_quadratic form (addVector left right) + evaluate_quadratic form (add_vector left right) - evaluate_quadratic form left - evaluate_quadratic form right --- Evidence that a particular integral quadratic form is known to be the --- diagonal of an integral symmetric bilinear form. There is intentionally no --- constructor for a general QuadraticProduct: an odd cross term would require --- division by 2 in the symmetric matrix. -public export +-- Evidence that an integral quadratic form has an integral symmetric diagonal +-- presentation. There is intentionally no constructor for a general +-- QuadraticProduct: an odd cross coefficient would require division by two. +export data DiagonalPresentation : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where SquareHasDiagonalPresentation : - (covector : ExactCovectorSample space) -> + {space : FiniteSpace} → + (covector : ExactCovectorSample space) → DiagonalPresentation (QuadraticSquare covector) SymmetricHasDiagonalPresentation : - (form : SymmetricBilinearForm space) -> + {space : FiniteSpace} → + (form : SymmetricBilinearForm space) → DiagonalPresentation (QuadraticFromSymmetric form) SumHasDiagonalPresentation : - {first : QuadraticForm space} -> - {second : QuadraticForm space} -> - DiagonalPresentation first -> - DiagonalPresentation second -> + {space : FiniteSpace} → + {first : QuadraticForm space} → + {second : QuadraticForm space} → + DiagonalPresentation first → + DiagonalPresentation second → DiagonalPresentation (QuadraticSum first second) ScaleHasDiagonalPresentation : - (scalar : Integer) -> - {form : QuadraticForm space} -> - DiagonalPresentation form -> + {space : FiniteSpace} → + (scalar : ±Number) → + {form : QuadraticForm space} → + DiagonalPresentation form → DiagonalPresentation (QuadraticScale scalar form) -public export +export presented_symmetric_form : - {space : FiniteSpace} -> - {form : QuadraticForm space} -> - DiagonalPresentation form -> + {space : FiniteSpace} → + {form : QuadraticForm space} → + DiagonalPresentation form → SymmetricBilinearForm space presented_symmetric_form (SquareHasDiagonalPresentation covector) = SymmetricSquare covector @@ -238,98 +259,92 @@ presented_symmetric_form (SumHasDiagonalPresentation first second) = (presented_symmetric_form first) (presented_symmetric_form second) presented_symmetric_form (ScaleHasDiagonalPresentation scalar form) = - SymmetricScale scalar (presented_symmetric_form form) + SymmetricScale scalar $ presented_symmetric_form form -- -------------------------------------------------------------------------- --- Exact complex samples, sesquilinear forms, and Hermitian forms +-- Exact complex samples and conjugation -- -------------------------------------------------------------------------- -public export -data ExactComplex = Complex Integer Integer +-- This Gaussian-integral value is an exact acceptance scalar, not the future +-- general complex-number hierarchy. +export +data ExactComplex = Complex ±Number ±Number -public export +export complex_zero : ExactComplex complex_zero = Complex 0 0 -public export +export complex_one : ExactComplex complex_one = Complex 1 0 -public export +export complex_i : ExactComplex complex_i = Complex 0 1 -public export -complex_add : ExactComplex -> ExactComplex -> ExactComplex +export +complex_add : ExactComplex → ExactComplex → ExactComplex complex_add (Complex a b) (Complex c d) = Complex (a + c) (b + d) -public export -complex_negate : ExactComplex -> ExactComplex -complex_negate (Complex a b) = Complex (-a) (-b) - -public export -complex_subtract : ExactComplex -> ExactComplex -> ExactComplex -complex_subtract left right = complex_add left (complex_negate right) +complex_negate : ExactComplex → ExactComplex +complex_negate (Complex real imaginary) = Complex (-real) (-imaginary) -public export -complex_multiply : ExactComplex -> ExactComplex -> ExactComplex +export +complex_multiply : ExactComplex → ExactComplex → ExactComplex complex_multiply (Complex a b) (Complex c d) = Complex (a * c - b * d) (a * d + b * c) -public export -complex_scale_integer : Integer -> ExactComplex -> ExactComplex -complex_scale_integer scalar (Complex real imaginary) = +scale_complex_integral : ±Number → ExactComplex → ExactComplex +scale_complex_integral scalar (Complex real imaginary) = Complex (scalar * real) (scalar * imaginary) -public export -conjugate : ExactComplex -> ExactComplex +export +conjugate : ExactComplex → ExactComplex conjugate (Complex real imaginary) = Complex real (-imaginary) -public export -real_part : ExactComplex -> Integer +export +real_part : ExactComplex → ±Number real_part (Complex real imaginary) = real -public export -imaginary_part : ExactComplex -> Integer -imaginary_part (Complex real imaginary) = imaginary - -public export -data RawExactComplexCoordinates : ℕ -> Type where +export +data RawExactComplexCoordinates : CoordinateRank → Type where UnsafeComplexCoordinateNil : RawExactComplexCoordinates Z UnsafeComplexCoordinateCons : - {n : ℕ} -> - ExactComplex -> - RawExactComplexCoordinates n -> + {n : CoordinateRank} → + ExactComplex → + RawExactComplexCoordinates n → RawExactComplexCoordinates (S n) -public export -data ExactComplexVectorSample : FiniteSpace -> Type where +export +data ExactComplexVectorSample : FiniteSpace → Type where UnsafeComplexVectorCoordinates : - {rank : ℕ} -> - {name : SpaceName rank} -> - RawExactComplexCoordinates rank -> + {rank : CoordinateRank} → + {name : SpaceName rank} → + RawExactComplexCoordinates rank → ExactComplexVectorSample (NamedFiniteSpace name) -public export -data ExactComplexCovectorSample : FiniteSpace -> Type where +export +data ExactComplexCovectorSample : FiniteSpace → Type where UnsafeComplexCovectorCoordinates : - {rank : ℕ} -> - {name : SpaceName rank} -> - RawExactComplexCoordinates rank -> + {rank : CoordinateRank} → + {name : SpaceName rank} → + RawExactComplexCoordinates rank → ExactComplexCovectorSample (NamedFiniteSpace name) -unsafe_zero_complex_coordinates : (n : ℕ) -> RawExactComplexCoordinates n +unsafe_zero_complex_coordinates : + (rank : CoordinateRank) → RawExactComplexCoordinates rank unsafe_zero_complex_coordinates Z = UnsafeComplexCoordinateNil unsafe_zero_complex_coordinates (S n) = - UnsafeComplexCoordinateCons complex_zero (unsafe_zero_complex_coordinates n) + UnsafeComplexCoordinateCons complex_zero $ unsafe_zero_complex_coordinates n unsafe_add_complex_coordinates : - {n : ℕ} -> - RawExactComplexCoordinates n -> - RawExactComplexCoordinates n -> - RawExactComplexCoordinates n -unsafe_add_complex_coordinates UnsafeComplexCoordinateNil UnsafeComplexCoordinateNil = + {rank : CoordinateRank} → + RawExactComplexCoordinates rank → + RawExactComplexCoordinates rank → + RawExactComplexCoordinates rank +unsafe_add_complex_coordinates UnsafeComplexCoordinateNil + UnsafeComplexCoordinateNil = UnsafeComplexCoordinateNil unsafe_add_complex_coordinates (UnsafeComplexCoordinateCons left left_rest) (UnsafeComplexCoordinateCons right right_rest) = @@ -338,24 +353,27 @@ unsafe_add_complex_coordinates (unsafe_add_complex_coordinates left_rest right_rest) unsafe_scale_complex_coordinates : - {n : ℕ} -> - ExactComplex -> - RawExactComplexCoordinates n -> - RawExactComplexCoordinates n + {rank : CoordinateRank} → + ExactComplex → + RawExactComplexCoordinates rank → + RawExactComplexCoordinates rank unsafe_scale_complex_coordinates scalar UnsafeComplexCoordinateNil = UnsafeComplexCoordinateNil -unsafe_scale_complex_coordinates scalar (UnsafeComplexCoordinateCons value rest) = - UnsafeComplexCoordinateCons - (complex_multiply scalar value) - (unsafe_scale_complex_coordinates scalar rest) +unsafe_scale_complex_coordinates + scalar + (UnsafeComplexCoordinateCons value rest) = + UnsafeComplexCoordinateCons + (complex_multiply scalar value) + (unsafe_scale_complex_coordinates scalar rest) unsafe_pair_complex_coordinates : - {n : ℕ} -> - RawExactComplexCoordinates n -> - RawExactComplexCoordinates n -> + {rank : CoordinateRank} → + RawExactComplexCoordinates rank → + RawExactComplexCoordinates rank → ExactComplex -unsafe_pair_complex_coordinates UnsafeComplexCoordinateNil UnsafeComplexCoordinateNil = - complex_zero +unsafe_pair_complex_coordinates + UnsafeComplexCoordinateNil + UnsafeComplexCoordinateNil = complex_zero unsafe_pair_complex_coordinates (UnsafeComplexCoordinateCons left left_rest) (UnsafeComplexCoordinateCons right right_rest) = @@ -363,150 +381,143 @@ unsafe_pair_complex_coordinates (complex_multiply left right) (unsafe_pair_complex_coordinates left_rest right_rest) -public export -add_complex_vector : - {space : FiniteSpace} -> - ExactComplexVectorSample space -> - ExactComplexVectorSample space -> - ExactComplexVectorSample space -add_complex_vector - (UnsafeComplexVectorCoordinates left) - (UnsafeComplexVectorCoordinates right) = - UnsafeComplexVectorCoordinates (unsafe_add_complex_coordinates left right) - -public export -scale_complex_vector : - {space : FiniteSpace} -> - ExactComplex -> - ExactComplexVectorSample space -> - ExactComplexVectorSample space -scale_complex_vector scalar (UnsafeComplexVectorCoordinates coordinates) = - UnsafeComplexVectorCoordinates (unsafe_scale_complex_coordinates scalar coordinates) - -public export +export add_complex_covector : - {space : FiniteSpace} -> - ExactComplexCovectorSample space -> - ExactComplexCovectorSample space -> + {space : FiniteSpace} → + ExactComplexCovectorSample space → + ExactComplexCovectorSample space → ExactComplexCovectorSample space add_complex_covector (UnsafeComplexCovectorCoordinates left) (UnsafeComplexCovectorCoordinates right) = - UnsafeComplexCovectorCoordinates (unsafe_add_complex_coordinates left right) + UnsafeComplexCovectorCoordinates $ + unsafe_add_complex_coordinates left right -public export +export scale_complex_covector : - {space : FiniteSpace} -> - ExactComplex -> - ExactComplexCovectorSample space -> + {space : FiniteSpace} → + ExactComplex → + ExactComplexCovectorSample space → ExactComplexCovectorSample space scale_complex_covector scalar (UnsafeComplexCovectorCoordinates coordinates) = - UnsafeComplexCovectorCoordinates - (unsafe_scale_complex_coordinates scalar coordinates) + UnsafeComplexCovectorCoordinates $ + unsafe_scale_complex_coordinates scalar coordinates -public export +export complex_contract : - {space : FiniteSpace} -> - ExactComplexCovectorSample space -> - ExactComplexVectorSample space -> + {space : FiniteSpace} → + ExactComplexCovectorSample space → + ExactComplexVectorSample space → ExactComplex complex_contract (UnsafeComplexCovectorCoordinates covector_coordinates) (UnsafeComplexVectorCoordinates vector_coordinates) = unsafe_pair_complex_coordinates covector_coordinates vector_coordinates -public export +export complex_plane_vector : - ExactComplex -> ExactComplex -> ExactComplexVectorSample planeSpace + ExactComplex → ExactComplex → ExactComplexVectorSample plane_space complex_plane_vector first second = - UnsafeComplexVectorCoordinates - (UnsafeComplexCoordinateCons first - (UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil)) + UnsafeComplexVectorCoordinates $ + UnsafeComplexCoordinateCons first $ + UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil -public export +export complex_plane_covector : - ExactComplex -> ExactComplex -> ExactComplexCovectorSample planeSpace + ExactComplex → ExactComplex → ExactComplexCovectorSample plane_space complex_plane_covector first second = - UnsafeComplexCovectorCoordinates - (UnsafeComplexCoordinateCons first - (UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil)) + UnsafeComplexCovectorCoordinates $ + UnsafeComplexCoordinateCons first $ + UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil complex_zero_covector : - {space : FiniteSpace} -> - ExactComplexVectorSample space -> + {space : FiniteSpace} → + ExactComplexVectorSample space → ExactComplexCovectorSample space -complex_zero_covector (UnsafeComplexVectorCoordinates coordinates) = - UnsafeComplexCovectorCoordinates - (unsafe_zero_complex_coordinates (spaceRank space)) - --- Convention: sesquilinear and Hermitian forms are conjugate-linear in the --- first argument and linear in the second. -public export -data SesquilinearForm : FiniteSpace -> Type where - SesquilinearZero : SesquilinearForm space +complex_zero_covector {space} (UnsafeComplexVectorCoordinates coordinates) = + UnsafeComplexCovectorCoordinates $ + unsafe_zero_complex_coordinates (space_rank space) + +-- -------------------------------------------------------------------------- +-- Sesquilinear and Hermitian forms +-- -------------------------------------------------------------------------- + +-- Convention: conjugate-linear in the first argument and linear in the second. +export +data SesquilinearForm : FiniteSpace → Type where + SesquilinearZero : {space : FiniteSpace} → SesquilinearForm space SesquilinearTensor : - ExactComplexCovectorSample space -> - ExactComplexCovectorSample space -> + {space : FiniteSpace} → + ExactComplexCovectorSample space → + ExactComplexCovectorSample space → SesquilinearForm space SesquilinearSum : - SesquilinearForm space -> - SesquilinearForm space -> - SesquilinearForm space - SesquilinearScale : ExactComplex -> SesquilinearForm space -> SesquilinearForm space + {space : FiniteSpace} → + SesquilinearForm space → SesquilinearForm space → SesquilinearForm space + SesquilinearScale : + {space : FiniteSpace} → + ExactComplex → SesquilinearForm space → SesquilinearForm space -public export +export evaluate_sesquilinear : - {space : FiniteSpace} -> - SesquilinearForm space -> - ExactComplexVectorSample space -> - ExactComplexVectorSample space -> + {space : FiniteSpace} → + SesquilinearForm space → + ExactComplexVectorSample space → + ExactComplexVectorSample space → ExactComplex evaluate_sesquilinear SesquilinearZero left right = complex_zero evaluate_sesquilinear (SesquilinearTensor first second) left right = complex_multiply - (conjugate (complex_contract first left)) + (conjugate $ complex_contract first left) (complex_contract second right) evaluate_sesquilinear (SesquilinearSum first second) left right = complex_add (evaluate_sesquilinear first left right) (evaluate_sesquilinear second left right) evaluate_sesquilinear (SesquilinearScale scalar form) left right = - complex_multiply scalar (evaluate_sesquilinear form left right) - -public export -data HermitianForm : FiniteSpace -> Type where - HermitianZero : HermitianForm space - HermitianSquare : ExactComplexCovectorSample space -> HermitianForm space + complex_multiply scalar $ evaluate_sesquilinear form left right + +export +data HermitianForm : FiniteSpace → Type where + HermitianZero : {space : FiniteSpace} → HermitianForm space + HermitianSquare : + {space : FiniteSpace} → + ExactComplexCovectorSample space → HermitianForm space HermitianCross : - ExactComplex -> - ExactComplexCovectorSample space -> - ExactComplexCovectorSample space -> + {space : FiniteSpace} → + ExactComplex → + ExactComplexCovectorSample space → + ExactComplexCovectorSample space → HermitianForm space - HermitianSum : HermitianForm space -> HermitianForm space -> HermitianForm space - HermitianScale : Integer -> HermitianForm space -> HermitianForm space - -public export + HermitianSum : + {space : FiniteSpace} → + HermitianForm space → HermitianForm space → HermitianForm space + HermitianScale : + {space : FiniteSpace} → + ±Number → HermitianForm space → HermitianForm space + +export evaluate_hermitian : - {space : FiniteSpace} -> - HermitianForm space -> - ExactComplexVectorSample space -> - ExactComplexVectorSample space -> + {space : FiniteSpace} → + HermitianForm space → + ExactComplexVectorSample space → + ExactComplexVectorSample space → ExactComplex evaluate_hermitian HermitianZero left right = complex_zero evaluate_hermitian (HermitianSquare covector) left right = complex_multiply - (conjugate (complex_contract covector left)) + (conjugate $ complex_contract covector left) (complex_contract covector right) evaluate_hermitian (HermitianCross coefficient first second) left right = complex_add (complex_multiply (complex_multiply - (conjugate (complex_contract first left)) + (conjugate $ complex_contract first left) coefficient) (complex_contract second right)) (complex_multiply (complex_multiply - (conjugate (complex_contract second left)) + (conjugate $ complex_contract second left) (conjugate coefficient)) (complex_contract first right)) evaluate_hermitian (HermitianSum first second) left right = @@ -514,19 +525,19 @@ evaluate_hermitian (HermitianSum first second) left right = (evaluate_hermitian first left right) (evaluate_hermitian second left right) evaluate_hermitian (HermitianScale scalar form) left right = - complex_scale_integer scalar (evaluate_hermitian form left right) + scale_complex_integral scalar $ evaluate_hermitian form left right -public export +export hermitian_as_sesquilinear : - {space : FiniteSpace} -> - HermitianForm space -> + {space : FiniteSpace} → + HermitianForm space → SesquilinearForm space hermitian_as_sesquilinear HermitianZero = SesquilinearZero hermitian_as_sesquilinear (HermitianSquare covector) = SesquilinearTensor covector covector hermitian_as_sesquilinear (HermitianCross coefficient first second) = SesquilinearSum - (SesquilinearScale coefficient (SesquilinearTensor first second)) + (SesquilinearScale coefficient $ SesquilinearTensor first second) (SesquilinearScale (conjugate coefficient) (SesquilinearTensor second first)) @@ -539,41 +550,41 @@ hermitian_as_sesquilinear (HermitianScale scalar form) = (Complex scalar 0) (hermitian_as_sesquilinear form) --- H(v,v) is real for values built by the closed Hermitian constructors. The --- exact Gaussian-integer model therefore exposes its real Hermitian quadratic --- quantity as Integer rather than pretending it is an ordinary complex --- QuadraticForm. -public export +-- H(v,v) is real for values built by the closed Hermitian constructors. The +-- exact sample exposes that real quantity as ±Number rather than pretending +-- that H is an ordinary complex QuadraticForm. +export hermitian_quadratic_quantity : - {space : FiniteSpace} -> - HermitianForm space -> - ExactComplexVectorSample space -> - Integer + {space : FiniteSpace} → + HermitianForm space → + ExactComplexVectorSample space → + ±Number hermitian_quadratic_quantity form vector = - real_part (evaluate_hermitian form vector vector) + real_part $ evaluate_hermitian form vector vector --- Fixing the first argument produces a linear complex covector. As a map from --- the first vector into the dual this operation is conjugate-linear, exactly as --- the chosen Hermitian convention requires. -public export +-- H(x,-) is a linear complex covector. As a map from x into the dual, this is +-- conjugate-linear under the convention above. +export hermitian_covector_at : - {space : FiniteSpace} -> - HermitianForm space -> - ExactComplexVectorSample space -> + {space : FiniteSpace} → + HermitianForm space → + ExactComplexVectorSample space → ExactComplexCovectorSample space hermitian_covector_at HermitianZero vector = complex_zero_covector vector hermitian_covector_at (HermitianSquare covector) vector = scale_complex_covector - (conjugate (complex_contract covector vector)) + (conjugate $ complex_contract covector vector) covector hermitian_covector_at (HermitianCross coefficient first second) vector = add_complex_covector (scale_complex_covector - (complex_multiply (conjugate (complex_contract first vector)) coefficient) + (complex_multiply + (conjugate $ complex_contract first vector) + coefficient) second) (scale_complex_covector (complex_multiply - (conjugate (complex_contract second vector)) + (conjugate $ complex_contract second vector) (conjugate coefficient)) first) hermitian_covector_at (HermitianSum first second) vector = @@ -586,223 +597,218 @@ hermitian_covector_at (HermitianScale scalar form) vector = (hermitian_covector_at form vector) -- -------------------------------------------------------------------------- --- Property certificates on the exact sample family +-- Evidence-bearing refinements on the exact plane sample -- -------------------------------------------------------------------------- -public export -plane_x : ExactCovectorSample planeSpace -plane_x = planeCovector 1 0 +export +plane_x : ExactCovectorSample plane_space +plane_x = plane_covector 1 0 -public export -plane_y : ExactCovectorSample planeSpace -plane_y = planeCovector 0 1 +export +plane_y : ExactCovectorSample plane_space +plane_y = plane_covector 0 1 -public export -plane_positive_quadratic : QuadraticForm planeSpace +export +plane_positive_quadratic : QuadraticForm plane_space plane_positive_quadratic = QuadraticSum (QuadraticSquare plane_x) (QuadraticSquare plane_y) -public export -plane_negative_quadratic : QuadraticForm planeSpace +export +plane_negative_quadratic : QuadraticForm plane_space plane_negative_quadratic = QuadraticScale (-1) plane_positive_quadratic -public export -plane_first_square : QuadraticForm planeSpace +export +plane_first_square : QuadraticForm plane_space plane_first_square = QuadraticSquare plane_x -public export -plane_negative_first_square : QuadraticForm planeSpace +export +plane_negative_first_square : QuadraticForm plane_space plane_negative_first_square = QuadraticScale (-1) plane_first_square -public export -plane_difference_of_squares : QuadraticForm planeSpace +export +plane_difference_of_squares : QuadraticForm plane_space plane_difference_of_squares = QuadraticSum (QuadraticSquare plane_x) - (QuadraticScale (-1) (QuadraticSquare plane_y)) + (QuadraticScale (-1) $ QuadraticSquare plane_y) -public export -plane_cross_quadratic : QuadraticForm planeSpace +export +plane_cross_quadratic : QuadraticForm plane_space plane_cross_quadratic = QuadraticProduct plane_x plane_y -public export +export data PositiveDefinite : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where PlaneSumOfSquaresPositive : PositiveDefinite plane_positive_quadratic -public export +export data NegativeDefinite : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where NegativePlaneSumOfSquares : NegativeDefinite plane_negative_quadratic -public export +export data PositiveSemidefinite : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where PositiveDefiniteIsSemidefinite : - {form : QuadraticForm space} -> - PositiveDefinite form -> - PositiveSemidefinite form + {space : FiniteSpace} → + {form : QuadraticForm space} → + PositiveDefinite form → PositiveSemidefinite form PlaneFirstSquareSemidefinite : PositiveSemidefinite plane_first_square -public export +export data NegativeSemidefinite : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where NegativeDefiniteIsSemidefinite : - {form : QuadraticForm space} -> - NegativeDefinite form -> - NegativeSemidefinite form + {space : FiniteSpace} → + {form : QuadraticForm space} → + NegativeDefinite form → NegativeSemidefinite form NegativePlaneFirstSquareSemidefinite : NegativeSemidefinite plane_negative_first_square -public export +export data QuadraticNondegenerate : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where PositiveDefiniteIsNondegenerate : - {form : QuadraticForm space} -> - PositiveDefinite form -> - QuadraticNondegenerate form + {space : FiniteSpace} → + {form : QuadraticForm space} → + PositiveDefinite form → QuadraticNondegenerate form NegativeDefiniteIsNondegenerate : - {form : QuadraticForm space} -> - NegativeDefinite form -> - QuadraticNondegenerate form + {space : FiniteSpace} → + {form : QuadraticForm space} → + NegativeDefinite form → QuadraticNondegenerate form PlaneDifferenceOfSquaresNondegenerate : QuadraticNondegenerate plane_difference_of_squares -public export +export data QuadraticDegenerate : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where PlaneFirstSquareDegenerate : QuadraticDegenerate plane_first_square -public export +export data Indefinite : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where PlaneDifferenceOfSquaresIndefinite : Indefinite plane_difference_of_squares -public export +export data Isotropic : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where PlaneDifferenceOfSquaresIsotropic : Isotropic plane_difference_of_squares -public export +export data Anisotropic : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where PositiveDefiniteIsAnisotropic : - {form : QuadraticForm space} -> - PositiveDefinite form -> - Anisotropic form + {space : FiniteSpace} → + {form : QuadraticForm space} → + PositiveDefinite form → Anisotropic form NegativeDefiniteIsAnisotropic : - {form : QuadraticForm space} -> - NegativeDefinite form -> - Anisotropic form - --- Every ordinary QuadraticForm in this module is Integer-valued on the exact --- lattice sample by construction. This certificate should not be generalized --- to future real/complex vector families without an explicit lattice. -public export + {space : FiniteSpace} → + {form : QuadraticForm space} → + NegativeDefinite form → Anisotropic form + +-- Every ordinary quadratic form in this exact slice is integral-valued on its +-- represented lattice. Do not generalize this certificate to a future real or +-- complex carrier without an explicit lattice. +export data IntegralQuadratic : - {space : FiniteSpace} -> QuadraticForm space -> Type where - ExactIntegerValued : - (form : QuadraticForm space) -> - IntegralQuadratic form - --- A doubled integral quadratic form is even. This is a structural certificate --- rather than a stored Boolean flag. -public export + {space : FiniteSpace} → QuadraticForm space → Type where + ExactIntegralValued : + {space : FiniteSpace} → + (form : QuadraticForm space) → IntegralQuadratic form + +export data EvenQuadratic : - {space : FiniteSpace} -> QuadraticForm space -> Type where + {space : FiniteSpace} → QuadraticForm space → Type where TwiceIntegralFormIsEven : - (form : QuadraticForm space) -> + {space : FiniteSpace} → + (form : QuadraticForm space) → EvenQuadratic (QuadraticScale 2 form) -public export +export positive_definite_is_nondegenerate : - {space : FiniteSpace} -> - {form : QuadraticForm space} -> - PositiveDefinite form -> + {space : FiniteSpace} → + {form : QuadraticForm space} → + PositiveDefinite form → QuadraticNondegenerate form positive_definite_is_nondegenerate evidence = PositiveDefiniteIsNondegenerate evidence -public export +export positive_definite_is_anisotropic : - {space : FiniteSpace} -> - {form : QuadraticForm space} -> - PositiveDefinite form -> + {space : FiniteSpace} → + {form : QuadraticForm space} → + PositiveDefinite form → Anisotropic form positive_definite_is_anisotropic evidence = PositiveDefiniteIsAnisotropic evidence -public export +export positive_definite_is_semidefinite : - {space : FiniteSpace} -> - {form : QuadraticForm space} -> - PositiveDefinite form -> + {space : FiniteSpace} → + {form : QuadraticForm space} → + PositiveDefinite form → PositiveSemidefinite form positive_definite_is_semidefinite evidence = PositiveDefiniteIsSemidefinite evidence -public export -complex_x : ExactComplexCovectorSample planeSpace +export +complex_x : ExactComplexCovectorSample plane_space complex_x = complex_plane_covector complex_one complex_zero -public export -complex_y : ExactComplexCovectorSample planeSpace +export +complex_y : ExactComplexCovectorSample plane_space complex_y = complex_plane_covector complex_zero complex_one -public export -plane_standard_hermitian : HermitianForm planeSpace +export +plane_standard_hermitian : HermitianForm plane_space plane_standard_hermitian = HermitianSum (HermitianSquare complex_x) (HermitianSquare complex_y) -public export +export data HermitianPositiveDefinite : - {space : FiniteSpace} -> HermitianForm space -> Type where + {space : FiniteSpace} → HermitianForm space → Type where StandardComplexPlanePositive : HermitianPositiveDefinite plane_standard_hermitian -public export +export data HermitianNondegenerate : - {space : FiniteSpace} -> HermitianForm space -> Type where + {space : FiniteSpace} → HermitianForm space → Type where HermitianPositiveIsNondegenerate : - {form : HermitianForm space} -> - HermitianPositiveDefinite form -> - HermitianNondegenerate form + {space : FiniteSpace} → + {form : HermitianForm space} → + HermitianPositiveDefinite form → HermitianNondegenerate form -public export +export hermitian_positive_is_nondegenerate : - {space : FiniteSpace} -> - {form : HermitianForm space} -> - HermitianPositiveDefinite form -> + {space : FiniteSpace} → + {form : HermitianForm space} → + HermitianPositiveDefinite form → HermitianNondegenerate form hermitian_positive_is_nondegenerate evidence = HermitianPositiveIsNondegenerate evidence -- -------------------------------------------------------------------------- --- Basis-dependent 2D matrix representations +-- Basis-dependent two-dimensional Gram representations -- -------------------------------------------------------------------------- --- The repository does not yet have a general basis or mathematical Matrix --- ontology. This contained plane slice establishes the correct abstraction --- boundary without presenting a rectangular array as the definition of a form. - -public export -data IntegerMatrix2 = Matrix2 Integer Integer Integer Integer +-- There is not yet a general Basis/Matrix ontology. These local representation +-- types establish the abstraction boundary without defining a form as a matrix. +export +data IntegralMatrix2 = Matrix2 ±Number ±Number ±Number ±Number -public export -data SymmetricIntegerMatrix2 = SymmetricMatrix2 Integer Integer Integer +export +data SymmetricIntegralMatrix2 = SymmetricMatrix2 ±Number ±Number ±Number -public export -full_symmetric_matrix : SymmetricIntegerMatrix2 -> IntegerMatrix2 +export +full_symmetric_matrix : SymmetricIntegralMatrix2 → IntegralMatrix2 full_symmetric_matrix (SymmetricMatrix2 first off_diagonal second) = Matrix2 first off_diagonal off_diagonal second -public export -transpose_integer_matrix : IntegerMatrix2 -> IntegerMatrix2 -transpose_integer_matrix (Matrix2 a b c d) = Matrix2 a c b d +transpose_integral_matrix : IntegralMatrix2 → IntegralMatrix2 +transpose_integral_matrix (Matrix2 a b c d) = Matrix2 a c b d -public export -multiply_integer_matrix : IntegerMatrix2 -> IntegerMatrix2 -> IntegerMatrix2 -multiply_integer_matrix +multiply_integral_matrix : IntegralMatrix2 → IntegralMatrix2 → IntegralMatrix2 +multiply_integral_matrix (Matrix2 a b c d) (Matrix2 e f g h) = Matrix2 @@ -811,112 +817,110 @@ multiply_integer_matrix (c * e + d * g) (c * f + d * h) -public export +export data PlaneBasis = StandardPlaneBasis | ShearedPlaneBasis -public export -basis_first : PlaneBasis -> ExactVectorSample planeSpace -basis_first StandardPlaneBasis = planeVector 1 0 -basis_first ShearedPlaneBasis = planeVector 1 0 +basis_first : PlaneBasis → ExactVectorSample plane_space +basis_first StandardPlaneBasis = plane_vector 1 0 +basis_first ShearedPlaneBasis = plane_vector 1 0 -public export -basis_second : PlaneBasis -> ExactVectorSample planeSpace -basis_second StandardPlaneBasis = planeVector 0 1 -basis_second ShearedPlaneBasis = planeVector 1 1 +basis_second : PlaneBasis → ExactVectorSample plane_space +basis_second StandardPlaneBasis = plane_vector 0 1 +basis_second ShearedPlaneBasis = plane_vector 1 1 -basis_dual_first : PlaneBasis -> ExactCovectorSample planeSpace -basis_dual_first StandardPlaneBasis = planeCovector 1 0 -basis_dual_first ShearedPlaneBasis = planeCovector 1 (-1) +basis_dual_first : PlaneBasis → ExactCovectorSample plane_space +basis_dual_first StandardPlaneBasis = plane_covector 1 0 +basis_dual_first ShearedPlaneBasis = plane_covector 1 (-1) -basis_dual_second : PlaneBasis -> ExactCovectorSample planeSpace -basis_dual_second StandardPlaneBasis = planeCovector 0 1 -basis_dual_second ShearedPlaneBasis = planeCovector 0 1 +basis_dual_second : PlaneBasis → ExactCovectorSample plane_space +basis_dual_second StandardPlaneBasis = plane_covector 0 1 +basis_dual_second ShearedPlaneBasis = plane_covector 0 1 -public export -data GramMatrix : PlaneBasis -> Type where - Gram : (basis : PlaneBasis) -> SymmetricIntegerMatrix2 -> GramMatrix basis +export +data GramMatrix : PlaneBasis → Type where + Gram : (basis : PlaneBasis) → SymmetricIntegralMatrix2 → GramMatrix basis -public export -gram_entries : {basis : PlaneBasis} -> GramMatrix basis -> SymmetricIntegerMatrix2 +export +gram_entries : {basis : PlaneBasis} → GramMatrix basis → SymmetricIntegralMatrix2 gram_entries (Gram basis matrix) = matrix -public export +export gram_matrix : - SymmetricBilinearForm planeSpace -> - (basis : PlaneBasis) -> + SymmetricBilinearForm plane_space → + (basis : PlaneBasis) → GramMatrix basis gram_matrix form basis = - Gram basis - (SymmetricMatrix2 + Gram basis $ + SymmetricMatrix2 (evaluate_symmetric form (basis_first basis) (basis_first basis)) (evaluate_symmetric form (basis_first basis) (basis_second basis)) - (evaluate_symmetric form (basis_second basis) (basis_second basis))) + (evaluate_symmetric form (basis_second basis) (basis_second basis)) -public export +export represented_symmetric_form : - {basis : PlaneBasis} -> - GramMatrix basis -> - SymmetricBilinearForm planeSpace -represented_symmetric_form (Gram basis (SymmetricMatrix2 first off_diagonal second)) = - SymmetricSum - (SymmetricScale first (SymmetricSquare (basis_dual_first basis))) - (SymmetricSum - (SymmetricScale off_diagonal - (SymmetricPair (basis_dual_first basis) (basis_dual_second basis))) - (SymmetricScale second (SymmetricSquare (basis_dual_second basis)))) - -public export + {basis : PlaneBasis} → + GramMatrix basis → + SymmetricBilinearForm plane_space +represented_symmetric_form + (Gram basis (SymmetricMatrix2 first off_diagonal second)) = + SymmetricSum + (SymmetricScale first $ SymmetricSquare $ basis_dual_first basis) + (SymmetricSum + (SymmetricScale off_diagonal $ + SymmetricPair (basis_dual_first basis) (basis_dual_second basis)) + (SymmetricScale second $ SymmetricSquare $ basis_dual_second basis)) + +export represented_quadratic_form : - {basis : PlaneBasis} -> - GramMatrix basis -> - QuadraticForm planeSpace + {basis : PlaneBasis} → + GramMatrix basis → + QuadraticForm plane_space represented_quadratic_form gram = - quadratic_from_symmetric (represented_symmetric_form gram) + quadratic_from_symmetric $ represented_symmetric_form gram -public export -basis_change_matrix : PlaneBasis -> PlaneBasis -> IntegerMatrix2 +basis_change_matrix : PlaneBasis → PlaneBasis → IntegralMatrix2 basis_change_matrix StandardPlaneBasis StandardPlaneBasis = Matrix2 1 0 0 1 basis_change_matrix StandardPlaneBasis ShearedPlaneBasis = Matrix2 1 1 0 1 basis_change_matrix ShearedPlaneBasis StandardPlaneBasis = Matrix2 1 (-1) 0 1 basis_change_matrix ShearedPlaneBasis ShearedPlaneBasis = Matrix2 1 0 0 1 -public export +export congruence_from : - {old_basis : PlaneBasis} -> - GramMatrix old_basis -> - (new_basis : PlaneBasis) -> - IntegerMatrix2 + {old_basis : PlaneBasis} → + GramMatrix old_basis → + (new_basis : PlaneBasis) → + IntegralMatrix2 congruence_from (Gram old_basis matrix) new_basis = let change = basis_change_matrix old_basis new_basis - left = multiply_integer_matrix - (transpose_integer_matrix change) + left = multiply_integral_matrix + (transpose_integral_matrix change) (full_symmetric_matrix matrix) - in multiply_integer_matrix left change + in multiply_integral_matrix left change -public export -plane_weighted_symmetric : SymmetricBilinearForm planeSpace +export +plane_weighted_symmetric : SymmetricBilinearForm plane_space plane_weighted_symmetric = SymmetricSum - (SymmetricScale 2 (SymmetricSquare plane_x)) - (SymmetricScale 3 (SymmetricSquare plane_y)) + (SymmetricScale 2 $ SymmetricSquare plane_x) + (SymmetricScale 3 $ SymmetricSquare plane_y) -public export -plane_weighted_quadratic : QuadraticForm planeSpace -plane_weighted_quadratic = quadratic_from_symmetric plane_weighted_symmetric +export +plane_weighted_quadratic : QuadraticForm plane_space +plane_weighted_quadratic = + quadratic_from_symmetric plane_weighted_symmetric -- -------------------------------------------------------------------------- --- Basis-dependent Hermitian matrices +-- Basis-dependent Hermitian representations -- -------------------------------------------------------------------------- -public export +export data ExactComplexMatrix2 = ComplexMatrix2 ExactComplex ExactComplex ExactComplex ExactComplex -public export -data HermitianMatrix2 = HermitianMatrix2 Integer ExactComplex Integer +export +data HermitianMatrix2 = HermitianMatrix2 ±Number ExactComplex ±Number -public export -full_hermitian_matrix : HermitianMatrix2 -> ExactComplexMatrix2 +full_hermitian_matrix : HermitianMatrix2 → ExactComplexMatrix2 full_hermitian_matrix (HermitianMatrix2 first off_diagonal second) = ComplexMatrix2 (Complex first 0) @@ -924,18 +928,15 @@ full_hermitian_matrix (HermitianMatrix2 first off_diagonal second) = (conjugate off_diagonal) (Complex second 0) -public export -transpose_complex_matrix : ExactComplexMatrix2 -> ExactComplexMatrix2 +transpose_complex_matrix : ExactComplexMatrix2 → ExactComplexMatrix2 transpose_complex_matrix (ComplexMatrix2 a b c d) = ComplexMatrix2 a c b d -public export -conjugate_transpose_complex_matrix : ExactComplexMatrix2 -> ExactComplexMatrix2 +conjugate_transpose_complex_matrix : ExactComplexMatrix2 → ExactComplexMatrix2 conjugate_transpose_complex_matrix (ComplexMatrix2 a b c d) = ComplexMatrix2 (conjugate a) (conjugate c) (conjugate b) (conjugate d) -public export multiply_complex_matrix : - ExactComplexMatrix2 -> ExactComplexMatrix2 -> ExactComplexMatrix2 + ExactComplexMatrix2 → ExactComplexMatrix2 → ExactComplexMatrix2 multiply_complex_matrix (ComplexMatrix2 a b c d) (ComplexMatrix2 e f g h) = @@ -945,91 +946,90 @@ multiply_complex_matrix (complex_add (complex_multiply c e) (complex_multiply d g)) (complex_add (complex_multiply c f) (complex_multiply d h)) -public export +export data ComplexPlaneBasis = StandardComplexBasis | ComplexShearedBasis -public export -complex_basis_first : ComplexPlaneBasis -> ExactComplexVectorSample planeSpace +complex_basis_first : + ComplexPlaneBasis → ExactComplexVectorSample plane_space complex_basis_first StandardComplexBasis = complex_plane_vector complex_one complex_zero complex_basis_first ComplexShearedBasis = complex_plane_vector complex_one complex_zero -public export -complex_basis_second : ComplexPlaneBasis -> ExactComplexVectorSample planeSpace +complex_basis_second : + ComplexPlaneBasis → ExactComplexVectorSample plane_space complex_basis_second StandardComplexBasis = complex_plane_vector complex_zero complex_one complex_basis_second ComplexShearedBasis = complex_plane_vector complex_i complex_one complex_basis_dual_first : - ComplexPlaneBasis -> ExactComplexCovectorSample planeSpace + ComplexPlaneBasis → ExactComplexCovectorSample plane_space complex_basis_dual_first StandardComplexBasis = complex_plane_covector complex_one complex_zero complex_basis_dual_first ComplexShearedBasis = complex_plane_covector complex_one (Complex 0 (-1)) complex_basis_dual_second : - ComplexPlaneBasis -> ExactComplexCovectorSample planeSpace + ComplexPlaneBasis → ExactComplexCovectorSample plane_space complex_basis_dual_second StandardComplexBasis = complex_plane_covector complex_zero complex_one complex_basis_dual_second ComplexShearedBasis = complex_plane_covector complex_zero complex_one -public export -data HermitianGramMatrix : ComplexPlaneBasis -> Type where +export +data HermitianGramMatrix : ComplexPlaneBasis → Type where HermitianGram : - (basis : ComplexPlaneBasis) -> - HermitianMatrix2 -> + (basis : ComplexPlaneBasis) → + HermitianMatrix2 → HermitianGramMatrix basis -public export +export hermitian_gram_entries : - {basis : ComplexPlaneBasis} -> - HermitianGramMatrix basis -> + {basis : ComplexPlaneBasis} → + HermitianGramMatrix basis → HermitianMatrix2 hermitian_gram_entries (HermitianGram basis matrix) = matrix -public export +export hermitian_gram_matrix : - HermitianForm planeSpace -> - (basis : ComplexPlaneBasis) -> + HermitianForm plane_space → + (basis : ComplexPlaneBasis) → HermitianGramMatrix basis hermitian_gram_matrix form basis = - HermitianGram basis - (HermitianMatrix2 - (real_part - (evaluate_hermitian form + HermitianGram basis $ + HermitianMatrix2 + (real_part $ + evaluate_hermitian form (complex_basis_first basis) - (complex_basis_first basis))) + (complex_basis_first basis)) (evaluate_hermitian form (complex_basis_first basis) (complex_basis_second basis)) - (real_part - (evaluate_hermitian form + (real_part $ + evaluate_hermitian form (complex_basis_second basis) - (complex_basis_second basis)))) + (complex_basis_second basis)) -public export +export represented_hermitian_form : - {basis : ComplexPlaneBasis} -> - HermitianGramMatrix basis -> - HermitianForm planeSpace + {basis : ComplexPlaneBasis} → + HermitianGramMatrix basis → + HermitianForm plane_space represented_hermitian_form (HermitianGram basis (HermitianMatrix2 first off_diagonal second)) = HermitianSum - (HermitianScale first (HermitianSquare (complex_basis_dual_first basis))) + (HermitianScale first $ HermitianSquare $ complex_basis_dual_first basis) (HermitianSum (HermitianCross off_diagonal (complex_basis_dual_first basis) (complex_basis_dual_second basis)) - (HermitianScale second - (HermitianSquare (complex_basis_dual_second basis)))) + (HermitianScale second $ + HermitianSquare $ complex_basis_dual_second basis)) -public export complex_basis_change_matrix : - ComplexPlaneBasis -> ComplexPlaneBasis -> ExactComplexMatrix2 + ComplexPlaneBasis → ComplexPlaneBasis → ExactComplexMatrix2 complex_basis_change_matrix StandardComplexBasis StandardComplexBasis = ComplexMatrix2 complex_one complex_zero complex_zero complex_one complex_basis_change_matrix StandardComplexBasis ComplexShearedBasis = @@ -1039,11 +1039,11 @@ complex_basis_change_matrix ComplexShearedBasis StandardComplexBasis = complex_basis_change_matrix ComplexShearedBasis ComplexShearedBasis = ComplexMatrix2 complex_one complex_zero complex_zero complex_one -public export +export hermitian_congruence_from : - {old_basis : ComplexPlaneBasis} -> - HermitianGramMatrix old_basis -> - (new_basis : ComplexPlaneBasis) -> + {old_basis : ComplexPlaneBasis} → + HermitianGramMatrix old_basis → + (new_basis : ComplexPlaneBasis) → ExactComplexMatrix2 hermitian_congruence_from (HermitianGram old_basis matrix) new_basis = let change = complex_basis_change_matrix old_basis new_basis @@ -1052,13 +1052,13 @@ hermitian_congruence_from (HermitianGram old_basis matrix) new_basis = (full_hermitian_matrix matrix) in multiply_complex_matrix left change --- This operation is intentionally present only as an acceptance oracle showing --- why ordinary transpose is wrong for complex Hermitian change of basis. -public export +-- Kept only as a negative oracle: ordinary transpose is not the Hermitian +-- basis-change operation. +export ordinary_transpose_congruence_oracle : - {old_basis : ComplexPlaneBasis} -> - HermitianGramMatrix old_basis -> - (new_basis : ComplexPlaneBasis) -> + {old_basis : ComplexPlaneBasis} → + HermitianGramMatrix old_basis → + (new_basis : ComplexPlaneBasis) → ExactComplexMatrix2 ordinary_transpose_congruence_oracle (HermitianGram old_basis matrix) @@ -1070,40 +1070,39 @@ ordinary_transpose_congruence_oracle in multiply_complex_matrix left change -- -------------------------------------------------------------------------- --- Characteristic-2 acceptance model +-- Characteristic-two acceptance model -- -------------------------------------------------------------------------- --- The current vector sample uses Integer scalars, but this tiny F2 model keeps --- a real characteristic-2 counterexample in the compiler acceptance suite. --- q(x,y)=xy is nonzero while the diagonal of its polar form is always zero. - -public export +-- The current named vector sample is integral. This tiny F2 model keeps a real +-- characteristic-two counterexample in compiler acceptance: q(x,y)=xy is +-- nonzero while the diagonal of its polar form is always zero. +export data F2 = F2Zero | F2One -f2_add : F2 -> F2 -> F2 +f2_add : F2 → F2 → F2 f2_add F2Zero value = value f2_add value F2Zero = value f2_add F2One F2One = F2Zero -f2_multiply : F2 -> F2 -> F2 +f2_multiply : F2 → F2 → F2 f2_multiply F2Zero value = F2Zero f2_multiply value F2Zero = F2Zero f2_multiply F2One F2One = F2One -public export +export data F2Plane = F2Vector F2 F2 -f2_vector_add : F2Plane -> F2Plane -> F2Plane +f2_vector_add : F2Plane → F2Plane → F2Plane f2_vector_add (F2Vector a b) (F2Vector c d) = F2Vector (f2_add a c) (f2_add b d) -public export -f2_cross_quadratic : F2Plane -> F2 +export +f2_cross_quadratic : F2Plane → F2 f2_cross_quadratic (F2Vector x y) = f2_multiply x y -public export -f2_polar : F2Plane -> F2Plane -> F2 +export +f2_polar : F2Plane → F2Plane → F2 f2_polar left right = f2_add - (f2_cross_quadratic (f2_vector_add left right)) + (f2_cross_quadratic $ f2_vector_add left right) (f2_add (f2_cross_quadratic left) (f2_cross_quadratic right)) From 49c95b29247f8d1af6517e00173cd869677ddae6 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:47:19 -0400 Subject: [PATCH 50/80] =?UTF-8?q?Move=20form=20acceptance=20to=20canonical?= =?UTF-8?q?=20Idri=C3=A7=20vocabulary?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../FormTests.idric | 81 ++++++++++--------- 1 file changed, 44 insertions(+), 37 deletions(-) diff --git a/_/examples/unified-higher-mathematics/FormTests.idric b/_/examples/unified-higher-mathematics/FormTests.idric index ed4753f77e..782093be1b 100644 --- a/_/examples/unified-higher-mathematics/FormTests.idric +++ b/_/examples/unified-higher-mathematics/FormTests.idric @@ -3,61 +3,63 @@ module FormTests import MathematicalSpaces import QuadraticForms -%default total %unbound_implicits off -- -------------------------------------------------------------------------- --- Abstract forms and quadratic/polar distinction +-- Abstract forms and the quadratic/polar distinction -- -------------------------------------------------------------------------- bilinear_evaluation_test : evaluate_bilinear (BilinearTensor plane_x plane_y) - (planeVector 3 4) - (planeVector 5 7) = 21 + (plane_vector 3 4) + (plane_vector 5 7) = the ±Number 21 bilinear_evaluation_test = Refl bilinear_to_dual_test : contract (bilinear_covector_at (BilinearTensor plane_x plane_y) - (planeVector 3 4)) - (planeVector 5 7) = 21 + (plane_vector 3 4)) + (plane_vector 5 7) = the ±Number 21 bilinear_to_dual_test = Refl quadratic_evaluation_test : - evaluate_quadratic plane_positive_quadratic (planeVector 3 4) = 25 + evaluate_quadratic plane_positive_quadratic (plane_vector 3 4) + = the ±Number 25 quadratic_evaluation_test = Refl primitive_cross_term_test : - evaluate_quadratic plane_cross_quadratic (planeVector 3 4) = 12 + evaluate_quadratic plane_cross_quadratic (plane_vector 3 4) + = the ±Number 12 primitive_cross_term_test = Refl polar_cross_term_test : evaluate_symmetric (polar_form plane_cross_quadratic) - (planeVector 1 0) - (planeVector 0 1) = 1 + (plane_vector 1 0) + (plane_vector 0 1) = the ±Number 1 polar_cross_term_test = Refl polar_difference_test : polar_difference plane_cross_quadratic - (planeVector 1 0) - (planeVector 0 1) = 1 + (plane_vector 1 0) + (plane_vector 0 1) = the ±Number 1 polar_difference_test = Refl -- q(x,y)=xy is not identified with the diagonal of its unhalved polar form. --- At (1,1), q=1 while polar(q)(v,v)=2 over the exact integral model. +-- At (1,1), q=1 while polar(q)(v,v)=2 in the exact integral model. quadratic_diagonal_value_test : - evaluate_quadratic plane_cross_quadratic (planeVector 1 1) = 1 + evaluate_quadratic plane_cross_quadratic (plane_vector 1 1) + = the ±Number 1 quadratic_diagonal_value_test = Refl polar_diagonal_value_test : evaluate_symmetric (polar_form plane_cross_quadratic) - (planeVector 1 1) - (planeVector 1 1) = 2 + (plane_vector 1 1) + (plane_vector 1 1) = the ±Number 2 polar_diagonal_value_test = Refl positive_diagonal_presentation : @@ -68,13 +70,13 @@ positive_diagonal_presentation = (SquareHasDiagonalPresentation plane_y) failing "Mismatch between" - odd_cross_term_has_no_square_presentation : + odd_cross_term_has_no_integral_symmetric_presentation : DiagonalPresentation plane_cross_quadratic - odd_cross_term_has_no_square_presentation = + odd_cross_term_has_no_integral_symmetric_presentation = SquareHasDiagonalPresentation plane_x -- -------------------------------------------------------------------------- --- Refinements are evidence, not Boolean metadata +-- Refinements carry evidence rather than Boolean metadata -- -------------------------------------------------------------------------- positive_definite_evidence : PositiveDefinite plane_positive_quadratic @@ -128,35 +130,39 @@ isotropic_evidence : Isotropic plane_difference_of_squares isotropic_evidence = PlaneDifferenceOfSquaresIsotropic integral_evidence : IntegralQuadratic plane_positive_quadratic -integral_evidence = ExactIntegerValued plane_positive_quadratic +integral_evidence = ExactIntegralValued plane_positive_quadratic even_evidence : EvenQuadratic (QuadraticScale 2 plane_positive_quadratic) even_evidence = TwiceIntegralFormIsEven plane_positive_quadratic indefinite_positive_witness_test : - evaluate_quadratic plane_difference_of_squares (planeVector 2 1) = 3 + evaluate_quadratic plane_difference_of_squares (plane_vector 2 1) + = the ±Number 3 indefinite_positive_witness_test = Refl indefinite_negative_witness_test : - evaluate_quadratic plane_difference_of_squares (planeVector 1 2) = (-3) + evaluate_quadratic plane_difference_of_squares (plane_vector 1 2) + = the ±Number (-3) indefinite_negative_witness_test = Refl isotropic_witness_test : - evaluate_quadratic plane_difference_of_squares (planeVector 1 1) = 0 + evaluate_quadratic plane_difference_of_squares (plane_vector 1 1) + = the ±Number 0 isotropic_witness_test = Refl degenerate_direction_test : - evaluate_quadratic plane_first_square (planeVector 0 1) = 0 + evaluate_quadratic plane_first_square (plane_vector 0 1) + = the ±Number 0 degenerate_direction_test = Refl -- -------------------------------------------------------------------------- -- Hermitian and sesquilinear semantics -- -------------------------------------------------------------------------- -complex_left : ExactComplexVectorSample planeSpace +complex_left : ExactComplexVectorSample plane_space complex_left = complex_plane_vector (Complex 1 1) complex_zero -complex_right : ExactComplexVectorSample planeSpace +complex_right : ExactComplexVectorSample plane_space complex_right = complex_plane_vector complex_one complex_zero hermitian_conjugates_first_argument_test : @@ -188,7 +194,7 @@ sesquilinear_view_test = Refl hermitian_quadratic_quantity_test : hermitian_quadratic_quantity plane_standard_hermitian - (complex_plane_vector (Complex 1 1) (Complex 2 (-1))) = 7 + (complex_plane_vector (Complex 1 1) (Complex 2 (-1))) = the ±Number 7 hermitian_quadratic_quantity_test = Refl hermitian_to_dual_test : @@ -207,11 +213,11 @@ hermitian_nondegenerate_evidence = hermitian_positive_is_nondegenerate hermitian_positive_evidence failing "Mismatch between" - hermitian_form_is_not_ordinary_quadratic : QuadraticForm planeSpace + hermitian_form_is_not_ordinary_quadratic : QuadraticForm plane_space hermitian_form_is_not_ordinary_quadratic = plane_standard_hermitian failing "Mismatch between" - ordinary_quadratic_is_not_hermitian : HermitianForm planeSpace + ordinary_quadratic_is_not_hermitian : HermitianForm plane_space ordinary_quadratic_is_not_hermitian = plane_positive_quadratic failing "Mismatch between" @@ -219,8 +225,8 @@ failing "Mismatch between" ordinary_vector_is_not_complex_vector = evaluate_hermitian plane_standard_hermitian - (planeVector 1 0) - (planeVector 0 1) + (plane_vector 1 0) + (plane_vector 0 1) -- -------------------------------------------------------------------------- -- Basis-dependent Gram representations @@ -248,17 +254,18 @@ ordinary_congruence_law_test = Refl basis_independent_value_from_standard_gram_test : evaluate_quadratic (represented_quadratic_form standard_weighted_gram) - (planeVector 2 1) = 11 + (plane_vector 2 1) = the ±Number 11 basis_independent_value_from_standard_gram_test = Refl basis_independent_value_from_sheared_gram_test : evaluate_quadratic (represented_quadratic_form sheared_weighted_gram) - (planeVector 2 1) = 11 + (plane_vector 2 1) = the ±Number 11 basis_independent_value_from_sheared_gram_test = Refl underlying_form_value_test : - evaluate_quadratic plane_weighted_quadratic (planeVector 2 1) = 11 + evaluate_quadratic plane_weighted_quadratic (plane_vector 2 1) + = the ±Number 11 underlying_form_value_test = Refl failing "Mismatch between" @@ -310,17 +317,17 @@ ordinary_transpose_is_different_test = Refl hermitian_basis_independent_standard_value_test : hermitian_quadratic_quantity (represented_hermitian_form standard_hermitian_gram) - (complex_plane_vector (Complex 1 1) (Complex 2 (-1))) = 7 + (complex_plane_vector (Complex 1 1) (Complex 2 (-1))) = the ±Number 7 hermitian_basis_independent_standard_value_test = Refl hermitian_basis_independent_sheared_value_test : hermitian_quadratic_quantity (represented_hermitian_form sheared_hermitian_gram) - (complex_plane_vector (Complex 1 1) (Complex 2 (-1))) = 7 + (complex_plane_vector (Complex 1 1) (Complex 2 (-1))) = the ±Number 7 hermitian_basis_independent_sheared_value_test = Refl -- -------------------------------------------------------------------------- --- Characteristic 2: quadratic and symmetric-bilinear data are not equivalent +-- Characteristic two: quadratic and symmetric-bilinear data are not equivalent -- -------------------------------------------------------------------------- f2_nonzero_quadratic_test : From 4b8b2a3d1d2602c59651b15ef8f548a5201552a3 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:47:58 -0400 Subject: [PATCH 51/80] =?UTF-8?q?Align=20form=20documentation=20with=20cur?= =?UTF-8?q?rent=20Idri=C3=A7=20surface?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../unified-higher-mathematics/README.md | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/_/examples/unified-higher-mathematics/README.md b/_/examples/unified-higher-mathematics/README.md index 438bf2f123..6aa64172f8 100644 --- a/_/examples/unified-higher-mathematics/README.md +++ b/_/examples/unified-higher-mathematics/README.md @@ -11,18 +11,18 @@ example, not a general mathematics library. name is itself indexed by its rank, so `PlaneName` cannot be reused at rank 128. The complete `FiniteSpace`, rather than its rank alone, indexes `ExactVectorSample`, `ExactCovectorSample`, `IndexedValue`, -`EuclideanStructure`, and the orthogonal types. Consequently `planeSpace` -and `imagePlaneSpace` remain different even though both have rank two. +`EuclideanStructure`, and the orthogonal types. Consequently `plane_space` +and `image_plane_space` remain different even though both have rank two. `ExactVectorSample space` and `ExactCovectorSample space` are separate -datatypes. They are explicitly the executable integer-coordinate fragment of -the named real coordinate space, not its complete carrier and not a claim that -the field of real scalars is `Integer`. Every represented sample nevertheless -denotes a genuine vector or covector. The metric-free operation is covector -evaluation: +datatypes. They are explicitly the executable signed-number-coordinate +fragment of the named real coordinate space, not its complete carrier and not +a claim that the field of real scalars is `±Number`. Every represented sample +nevertheless denotes a genuine vector or covector. The metric-free operation +is covector evaluation: ```idris -contract : ExactCovectorSample space -> ExactVectorSample space -> Integer +contract : ExactCovectorSample space → ExactVectorSample space → ±Number ``` `RawExactCoordinates`, `UnsafeVectorCoordinates`, and the other @@ -34,7 +34,7 @@ API never performs such a conversion silently. There is deliberately no checked vector-to-covector conversion in `MathematicalSpaces`. `EuclideanStructure space` supplies that additional -identification through `lowerIndex` and `raiseIndex`; `dot`, `norm`, +identification through `lower_index` and `raise_index`; `dot`, `norm`, `distance`, and index raising/lowering on exact samples all require the structure explicitly. The current witness is the standard coordinate Euclidean structure. `norm` and `distance` retain an exact symbolic square @@ -45,7 +45,7 @@ real-scalar representation remains deliberately unchosen. Euclidean structure and by `Preserving` or `Reversing`. Its public constructors are restricted to the settled identity, first-axis reflection, first-plane quarter-turn, exact integral unit-quaternion rotation, and -composition. `applyOrthogonalExact` interprets that same closed syntax on +composition. `apply_orthogonal_exact` interprets that same closed syntax on exact samples; composition means `left (right sample)`. This removes the old disconnect between marker values and separate generator evaluators. The orientation indices record the reviewed standard maps; Idriç does not derive @@ -57,15 +57,15 @@ arbitrary user-supplied matrix or represent every quaternionic rotation. The Einstein-style experiment is intentionally only a one-index kernel. `LowerIndex` contains a covector, `UpperIndex` contains a vector, and -`contractIndex` accepts opposite variance over the same complete named-space +`contract_index` accepts opposite variance over the same complete named-space index. Equal ranks neither erase a name mismatch nor permit same-variance -contraction. A variance change goes through `lowerIndexed` or `raiseIndexed` +contraction. A variance change goes through `lower_indexed` or `raise_indexed` and therefore requires a Euclidean structure. ## Quadratic and Hermitian forms -`QuadraticForms.idric` adds forms as mathematical objects above their -coordinate representations: +`QuadraticForms.idric` adds forms as mathematical objects above coordinate +representations: - `BilinearForm` and `SymmetricBilinearForm`; - a distinct primitive `QuadraticForm`, including cross terms that need not be @@ -108,10 +108,10 @@ the Conway repository's *The Sensual (Quadratic) Form* reading note. The finite presheaf example remains in `PresheafRestriction.idric`. It shares the strategy of making inclusions and section domains indices, but it does not -depend on Euclidean geometry. It models three opens, their stated -inclusions, restriction identity and composition, and componentwise -restriction of a formal elementary pair. It claims neither a general -presheaf interface nor a tensor-product or sheaf construction. +depend on Euclidean geometry. It models three opens, their stated inclusions, +restriction identity and composition, and componentwise restriction of a +formal elementary pair. It claims neither a general presheaf interface nor a +tensor-product or sheaf construction. `TopologyFacts.idric` preserves the mathematically settled slice of #45: @@ -144,7 +144,7 @@ The named-fact proof of concept contains one entry, S^2 and its typed conclusion is the corresponding two-component separation fact. Here the embedding value is an explicit assumption token; no map or injectivity property is inferred or checked. A `NamedFact H C` stores -human-declared attribution plus an Idriç function `(h : H) -> C h`. Lookup +human-declared attribution plus an Idriç function `(h : H) → C h`. Lookup explicitly applies that selected entry to `TypedContext H`; the type checker enforces the exact hypothesis type, and the answer says that it came through named lookup rather than unification. This is the boundary requested by #42 From 14f9cec338c2b686c07d77a4a378a428c5af41d9 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 19:48:29 -0400 Subject: [PATCH 52/80] =?UTF-8?q?Align=20quadratic-form=20architecture=20n?= =?UTF-8?q?ote=20with=20Idri=C3=A7=20style?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../QUADRATIC-FORMS.md | 60 ++++++++++--------- 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md b/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md index 253a2d9707..3dea4b1ffb 100644 --- a/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md +++ b/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md @@ -1,7 +1,7 @@ # Quadratic and Hermitian forms -This note records the abstraction boundary exercised by `QuadraticForms.idric` and -`FormTests.idric`. +This note records the abstraction boundary exercised by `QuadraticForms.idric` +and `FormTests.idric`. The central rule is: @@ -14,8 +14,8 @@ complex quadratic form. ## Existing Idriç linear-algebra inventory -The current canonical branch already has one useful programmer-facing semantic -core in `unified-higher-mathematics`: +The current higher-mathematics line already has one useful programmer-facing +semantic core: - `FiniteSpace` distinguishes named finite spaces, not merely dimensions. - `ExactVectorSample space` and `ExactCovectorSample space` are distinct types. @@ -38,9 +38,9 @@ mistaken for this ontology: There is not yet a mature programmer-facing general `Basis`, mathematical `Matrix`, complex scalar, scalar field, module, linear map, or linear -isomorphism ontology on the canonical branch. The previous higher-mathematics -README explicitly deferred multiple bases, indefinite bilinear forms, arbitrary -matrix certification, and scalar-field abstraction. +isomorphism ontology. The earlier higher-mathematics work explicitly deferred +general multiple-basis support, arbitrary matrix certification, and scalar-field +abstraction. That is the architectural limit for this patch. It extends the compiler-checked semantic experiment rather than silently upgrading inherited Idris containers @@ -59,14 +59,14 @@ into mathematical objects. - `HermitianForm V`: a closed Hermitian construction whose cross terms include their conjugate partner. -The ordinary executable sample continues to use exact integer vectors. This is -not a claim that `Integer` is the scalar field of the named real spaces. It is a -small exact lattice model consistent with the existing higher-mathematics -slice. +The ordinary executable sample continues to use exact `±Number` coordinates. +This is not a claim that `±Number` is the scalar field of the named real spaces. +It is a small exact integral-lattice model consistent with the existing +higher-mathematics slice. -The complex executable sample uses exact Gaussian-integer coordinates. It adds +The complex executable sample uses exact Gaussian-integral coordinates. It adds separate complex vectors and covectors rather than reinterpreting ordinary -integer vectors. +integral vectors. ## Quadratic form versus bilinear form @@ -85,7 +85,7 @@ quadratic form is known to have an integral symmetric diagonal presentation. There is no generic constructor for an odd product term `alpha(v) beta(v)`, because its symmetric presentation would require division by two. -This leaves the type boundary correct for future characteristic-2 scalars. +This leaves the type boundary correct for future characteristic-two scalars. `FormTests.idric` also contains an explicit two-dimensional F2 example: `q(x,y)=xy` is nonzero, while the diagonal of its polar form vanishes. Thus the acceptance suite cannot regress to a universal quadratic/symmetric-bilinear @@ -103,7 +103,7 @@ A Hermitian form satisfies the intended structural law `H(x,y) = conjugate(H(y,x))`. `hermitian_quadratic_quantity H v` exposes the real diagonal quantity `H(v,v)` -in the exact Gaussian-integer model. It does not coerce the Hermitian form into +in the exact Gaussian-integral model. It does not coerce the Hermitian form into an ordinary `QuadraticForm`. Fixing the first argument of a Hermitian form yields a complex covector in the @@ -149,9 +149,9 @@ missing scalar/lattice architecture exists: - odd integral forms; - unimodularity; - signature and fixed signature; -- general nondegeneracy/radical machinery in characteristic 2; +- general nondegeneracy/radical machinery in characteristic two; - decision procedures for definiteness or degeneracy of arbitrary forms; -- real positivity over an ordered field rather than the exact integer sample. +- real positivity over an ordered field rather than the exact integral sample. Unimodularity in particular needs an explicit lattice and basis-independent statement, not merely `det(matrix) = +/-1` attached to an arbitrary coordinate @@ -167,8 +167,8 @@ a contained two-dimensional representation slice. form therefore yields different matrices in the standard and sheared bases. The compiler rejects assigning a Gram matrix for one basis to the other basis. A Gram matrix plus its basis can reconstruct the represented symmetric form, -and evaluating the reconstructed form is independent of which of the two -representations was used. +and evaluating the reconstructed form is independent of which representation +was used. The ordinary basis-change acceptance example checks @@ -182,7 +182,7 @@ where `P*` is conjugate transpose. The same fixture computes the ordinary transpose result separately and obtains a different, non-Hermitian matrix. This keeps transpose and conjugate transpose visibly distinct in executable source. -The local `IntegerMatrix2` and `ExactComplexMatrix2` types are deliberately +The local `IntegralMatrix2` and `ExactComplexMatrix2` types are deliberately representation-level helpers. They are not proposed as the repository's future general `Matrix` abstraction. @@ -194,19 +194,25 @@ For bilinear forms, `bilinear_covector_at B x` constructs the covector vector-to-covector coercion. A nondegenerate form should eventually yield an isomorphism between a vector -space and the appropriate dual (or conjugate-dual structure in the Hermitian -case). The repository does not yet have general linear-map/isomorphism objects -strong enough to express that statement without inventing a one-off wrapper, -so integration stops at the mathematically valid lowering map and indexed -nondegeneracy evidence. +space and the appropriate dual, or the appropriate conjugate-dual structure in +the Hermitian case. The repository does not yet have general +linear-map/isomorphism objects strong enough to express that statement without +inventing a one-off wrapper, so integration stops at the mathematically valid +lowering map and indexed nondegeneracy evidence. ## Compiler versus library -No new compiler primitive is required for these forms. The mathematical object +No new quadratic-form compiler primitive is required. The mathematical object types, closed constructions, refinements, and basis-indexed representations are library-level code. Existing dependent indices and ordinary equality proofs are enough for this slice. +The source itself follows the current Idriç surface used by the higher-math +foundation: `±Number`, `Cardinality`/`CoordinateRank`, Unicode `→`, snake_case +operations, and implicit file totality. The compiler support for that surface is +provided by the source-style work on which this form branch is stacked; the +form API does not deform its mathematics around the older Idris vocabulary. + A future generalization should improve the mathematical library layer first: law-bearing scalar/ring/field and involution structures, modules, bases, linear maps, duals, and basis-aware matrices. It should not special-case quadratic @@ -218,5 +224,5 @@ The companion Conway repository already has a chapter guide for John H. Conway's *The Sensual (Quadratic) Form* in [Conway PR #6](https://github.com/isomorphismes/Conway/pull/6). That note makes the same basis-independent form / basis-dependent Gram-matrix distinction and -records the characteristic-2 and Hermitian cautions. This file links to it +records the characteristic-two and Hermitian cautions. This file links to it rather than duplicating the chapter-by-chapter material. From 38065357c160caf8ffc52d6efdc5a2cebbecd6de Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 21:07:18 -0400 Subject: [PATCH 53/80] Add complex and projective structural semantics --- COMPLEX-PROJECTIVE.md | 61 +++++++ .../ComplexProjective.idric | 168 ++++++++++++++++++ .../ComplexProjectiveTests.idric | 107 +++++++++++ _/fixtures/complex-projective/float32.json | 127 +++++++++++++ _/tests/idris2/basic/edric009/expected | 1 + _/tests/idris2/basic/edric009/run | 14 ++ 6 files changed, 478 insertions(+) create mode 100644 COMPLEX-PROJECTIVE.md create mode 100644 _/examples/unified-higher-mathematics/ComplexProjective.idric create mode 100644 _/examples/unified-higher-mathematics/ComplexProjectiveTests.idric create mode 100644 _/fixtures/complex-projective/float32.json diff --git a/COMPLEX-PROJECTIVE.md b/COMPLEX-PROJECTIVE.md new file mode 100644 index 0000000000..d937eb8fea --- /dev/null +++ b/COMPLEX-PROJECTIVE.md @@ -0,0 +1,61 @@ +# Complex and projective semantic boundary + +This slice establishes the type-level distinction needed by complex and projective arithmetic without choosing a machine representation or silently settling the separate floating-precision work. + +## What the checker now distinguishes + +`ComplexCoordinates complex n` is the structural type of an element of a complex coordinate space with exactly `n` coordinates. `ComplexProjectivePoint complex n` is a projective point with a nonzero homogeneous representative containing exactly `n + 1` complex coordinates. + +The `complex` parameter is deliberate. The current canonical tree does not yet have a settled general real-scalar hierarchy whose precision semantics can honestly define the numerical carrier for the mathematical field C. This module therefore does **not** define C as two `Double`s, two `Float32`s, a GLSL `vec2`, or an x86 register pair merely to obtain executable code. + +The concrete executable Float32 implementation currently belongs to the x86-64 leading backend and is checked against the shared corpus at `_/fixtures/complex-projective/float32.json`. The exact `ExactComplex` type in `QuadraticForms.idric` remains a Gaussian-integral test scalar used only to make structural identities reduce exactly in compiler acceptance. + +## Projective semantics + +For projective dimension `n`, a representative has `n + 1` homogeneous coordinates. The all-zero tuple is excluded by `NonzeroHomogeneousCoordinates`. + +The runtime representation may carry a homogeneous tuple directly. The semantic point is the equivalence class under common nonzero complex rescaling: + +```text +[z0:...:zn] = [lambda z0:...:lambda zn], lambda != 0. +``` + +`projective_rescaling_witness` expresses one explicit witness for that quotient relation. Raw component equality is not projective equality. There is intentionally no ordinary `Eq` instance, vector addition, or multiplication for `ComplexProjectivePoint`. + +Normalization is not part of construction. A backend may choose a gauge for numerical stability, chart extraction, comparison, serialization, or rendering, but common scale is otherwise retained as redundant homogeneous information. + +## Affine chart + +`affine_to_projective` implements + +```text +(z1,...,zn) -> [1:z1:...:zn]. +``` + +`projective_first_chart` divides by the first homogeneous coordinate only when that coordinate is nonzero. For CP^1, `[0:1]` therefore remains the point at infinity and is outside this chart. + +## Holomorphic boundary + +Projective structure does not make observational operations holomorphic. Conjugation, magnitude, phase, gauge choice, and coloring may be used for observation or rendering. They must not be inserted into an evolving value that is meant to remain holomorphic. + +The shared render fixture uses the current whole-plane explorer model + +```text +f(z) = R(z) exp(q(z)) +``` + +where `R` carries an explicit zero/pole divisor and `q` is an entire polynomial. The fixture contains no lasso, overlapping-disc, path, Riemann-surface, or lacunary machinery. + +## Precision and tolerances + +The shared numerical corpus declares Float32 explicitly. Its machine implementations must preserve that declared width. A wider host calculation may be used only as an external oracle. + +Exact-binary32 cases use exact comparison. Ordinary floating cases use an error bound derived from binary32 epsilon and the conditioning/operation count of the case. The current bounded complex-exponential implementation is a degree-7 Taylor polynomial and is accepted only for input magnitude at most `0.5`; its analytic truncation bound is + +```text +exp(|q|) |q|^8 / 8! +``` + +plus a separately recorded binary32 rounding allowance. Inputs outside the declared approximation domain must be rejected rather than silently accepted with a larger arbitrary tolerance. + +Projective comparison uses rescaling witnesses or invariant cross-products such as `zi*wj - zj*wi`, never raw homogeneous component equality. diff --git a/_/examples/unified-higher-mathematics/ComplexProjective.idric b/_/examples/unified-higher-mathematics/ComplexProjective.idric new file mode 100644 index 0000000000..bd94d9453e --- /dev/null +++ b/_/examples/unified-higher-mathematics/ComplexProjective.idric @@ -0,0 +1,168 @@ +module ComplexProjective + +import MathematicalSpaces + +%unbound_implicits off + +-- Complex arithmetic and machine representation are separate questions. +-- This module establishes the structural types needed by the checker without +-- choosing Float16, Float32, Cartesian machine pairs, SIMD lanes, or a backend +-- ABI. The `complex` parameter is the scalar carrier supplied by a concrete +-- complex-arithmetic implementation. In the exact acceptance test it is the +-- Gaussian-integral ExactComplex fixture from QuadraticForms; that fixture is +-- not the definition of the mathematical complex numbers. + +-- An element of C^n has n complex coordinates. Dimension is part of the type, +-- so a C^2 value cannot be consumed where C^3 is required. +export +data ComplexCoordinates : Type → CoordinateRank → Type where + NoComplexCoordinates : ComplexCoordinates complex Z + ComplexCoordinate : + {remaining : CoordinateRank} → + complex → + ComplexCoordinates complex remaining → + ComplexCoordinates complex (S remaining) + +export +map_complex_coordinates : + (map_coordinate : source → target) → + ComplexCoordinates source dimension → + ComplexCoordinates target dimension +map_complex_coordinates map_coordinate NoComplexCoordinates = + NoComplexCoordinates +map_complex_coordinates + map_coordinate + (ComplexCoordinate coordinate remaining) = + ComplexCoordinate + (map_coordinate coordinate) + (map_complex_coordinates map_coordinate remaining) + +export +scale_complex_coordinates : + (multiply_complex : complex → complex → complex) → + complex → + ComplexCoordinates complex dimension → + ComplexCoordinates complex dimension +scale_complex_coordinates + multiply_complex + scalar + NoComplexCoordinates = NoComplexCoordinates +scale_complex_coordinates + multiply_complex + scalar + (ComplexCoordinate coordinate remaining) = + ComplexCoordinate + (multiply_complex scalar coordinate) + (scale_complex_coordinates multiply_complex scalar remaining) + +-- The constructor is explicitly unsafe because this module does not invent a +-- fake generic proof that an arbitrary complex carrier can decide nonzeroness. +-- Concrete complex arithmetic should expose checked constructors appropriate +-- to its scalar semantics. +export +record NonzeroComplexScalar (complex : Type) where + constructor UnsafeKnownNonzeroComplexScalar + nonzero_complex_value : complex + +-- CP^n uses n+1 homogeneous complex coordinates, with the all-zero tuple +-- excluded. The witness constructor is unsafe for the same reason as above: +-- nonzeroness belongs to the concrete complex carrier, not to this structural +-- module. +export +record NonzeroHomogeneousCoordinates + (complex : Type) + (projective_dimension : CoordinateRank) where + constructor UnsafeKnownNonzeroHomogeneousCoordinates + homogeneous_coordinates : + ComplexCoordinates complex (S projective_dimension) + +-- A projective point carries a homogeneous representative but has quotient +-- semantics. There is deliberately no Eq instance and no vector addition or +-- multiplication on this type. Common nonzero complex rescaling is expressed +-- by the witness type below. +export +data ComplexProjectivePoint : Type → CoordinateRank → Type where + UnsafeProjectiveClass : + NonzeroHomogeneousCoordinates complex projective_dimension → + ComplexProjectivePoint complex projective_dimension + +export +homogeneous_representative : + ComplexProjectivePoint complex projective_dimension → + NonzeroHomogeneousCoordinates complex projective_dimension +homogeneous_representative (UnsafeProjectiveClass representative) = + representative + +-- For a chosen nonzero lambda this type is inhabited exactly when +-- +-- lambda * left = right +-- +-- coordinate by coordinate. Projective equivalence is the existence of such +-- a nonzero lambda. Keeping the scale as explicit evidence prevents raw +-- component equality from being mistaken for equality in CP^n. +export +projective_rescaling_witness : + (multiply_complex : complex → complex → complex) → + (scale : NonzeroComplexScalar complex) → + (left : NonzeroHomogeneousCoordinates complex projective_dimension) → + (right : NonzeroHomogeneousCoordinates complex projective_dimension) → + Type +projective_rescaling_witness + multiply_complex + (UnsafeKnownNonzeroComplexScalar scalar) + (UnsafeKnownNonzeroHomogeneousCoordinates left) + (UnsafeKnownNonzeroHomogeneousCoordinates right) = + scale_complex_coordinates multiply_complex scalar left = right + +-- (z1,...,zn) maps to [1:z1:...:zn]. The first homogeneous coordinate is +-- supplied as a known-nonzero complex scalar rather than inferred from a +-- machine representation. +export +affine_to_projective : + NonzeroComplexScalar complex → + ComplexCoordinates complex projective_dimension → + ComplexProjectivePoint complex projective_dimension +affine_to_projective + one + affine_coordinates = + UnsafeProjectiveClass $ + UnsafeKnownNonzeroHomogeneousCoordinates $ + ComplexCoordinate + (nonzero_complex_value one) + affine_coordinates + +private +divide_coordinates_by : + (divide_complex : complex → complex → complex) → + complex → + ComplexCoordinates complex dimension → + ComplexCoordinates complex dimension +divide_coordinates_by divide_complex denominator NoComplexCoordinates = + NoComplexCoordinates +divide_coordinates_by + divide_complex + denominator + (ComplexCoordinate coordinate remaining) = + ComplexCoordinate + (divide_complex coordinate denominator) + (divide_coordinates_by divide_complex denominator remaining) + +-- Extract the affine chart with first homogeneous coordinate nonzero. The +-- operation is partial: [0:z1:...:zn] is outside this chart. In particular, +-- [0:1] in CP^1 is the point at infinity and returns Nothing here. +export +projective_first_chart : + (is_zero_complex : complex → Bool) → + (divide_complex : complex → complex → complex) → + ComplexProjectivePoint complex projective_dimension → + Maybe (ComplexCoordinates complex projective_dimension) +projective_first_chart + is_zero_complex + divide_complex + (UnsafeProjectiveClass + (UnsafeKnownNonzeroHomogeneousCoordinates + (ComplexCoordinate first remaining))) = + if is_zero_complex first + then Nothing + else Just $ + divide_coordinates_by divide_complex first remaining diff --git a/_/examples/unified-higher-mathematics/ComplexProjectiveTests.idric b/_/examples/unified-higher-mathematics/ComplexProjectiveTests.idric new file mode 100644 index 0000000000..69c9acdd15 --- /dev/null +++ b/_/examples/unified-higher-mathematics/ComplexProjectiveTests.idric @@ -0,0 +1,107 @@ +module ComplexProjectiveTests + +import MathematicalSpaces +import QuadraticForms +import ComplexProjective + +%unbound_implicits off + +-- ExactComplex is used only as an exact algebraic fixture for the structural +-- complex/projective API. It remains the Gaussian-integral acceptance scalar +-- defined in QuadraticForms, not the future general complex-number carrier. + +cp2_left : NonzeroHomogeneousCoordinates ExactComplex 2 +cp2_left = + UnsafeKnownNonzeroHomogeneousCoordinates $ + ComplexCoordinate complex_one $ + ComplexCoordinate complex_i $ + ComplexCoordinate (Complex 2 0) NoComplexCoordinates + +cp2_scaled_by_two : NonzeroHomogeneousCoordinates ExactComplex 2 +cp2_scaled_by_two = + UnsafeKnownNonzeroHomogeneousCoordinates $ + ComplexCoordinate (Complex 2 0) $ + ComplexCoordinate (Complex 0 2) $ + ComplexCoordinate (Complex 4 0) NoComplexCoordinates + +cp2_scale_two : NonzeroComplexScalar ExactComplex +cp2_scale_two = UnsafeKnownNonzeroComplexScalar (Complex 2 0) + +cp2_real_rescaling_test : + projective_rescaling_witness + complex_multiply + cp2_scale_two + cp2_left + cp2_scaled_by_two +cp2_real_rescaling_test = Refl + +cp2_scaled_by_i : NonzeroHomogeneousCoordinates ExactComplex 2 +cp2_scaled_by_i = + UnsafeKnownNonzeroHomogeneousCoordinates $ + ComplexCoordinate complex_i $ + ComplexCoordinate (Complex (-1) 0) $ + ComplexCoordinate (Complex 0 2) NoComplexCoordinates + +cp2_scale_i : NonzeroComplexScalar ExactComplex +cp2_scale_i = UnsafeKnownNonzeroComplexScalar complex_i + +cp2_phase_rescaling_test : + projective_rescaling_witness + complex_multiply + cp2_scale_i + cp2_left + cp2_scaled_by_i +cp2_phase_rescaling_test = Refl + +affine_value : ComplexCoordinates ExactComplex 1 +affine_value = + ComplexCoordinate (Complex 3 (-2)) NoComplexCoordinates + +exact_complex_is_zero : ExactComplex → Bool +exact_complex_is_zero (Complex 0 0) = True +exact_complex_is_zero _ = False + +-- The affine embedding fixes the first homogeneous coordinate to 1, so this +-- exact fixture only needs division by that unit. It is intentionally not +-- advertised as Gaussian-integer division. +exact_divide_by_embedding_unit : ExactComplex → ExactComplex → ExactComplex +exact_divide_by_embedding_unit numerator (Complex 1 0) = numerator +exact_divide_by_embedding_unit numerator _ = numerator + +affine_embedding : ComplexProjectivePoint ExactComplex 1 +affine_embedding = + affine_to_projective + (UnsafeKnownNonzeroComplexScalar complex_one) + affine_value + +affine_chart_round_trip_test : + projective_first_chart + exact_complex_is_zero + exact_divide_by_embedding_unit + affine_embedding = Just affine_value +affine_chart_round_trip_test = Refl + +cp1_infinity : ComplexProjectivePoint ExactComplex 1 +cp1_infinity = + UnsafeProjectiveClass $ + UnsafeKnownNonzeroHomogeneousCoordinates $ + ComplexCoordinate complex_zero $ + ComplexCoordinate complex_one NoComplexCoordinates + +cp1_infinity_not_in_first_chart_test : + projective_first_chart + exact_complex_is_zero + exact_divide_by_embedding_unit + cp1_infinity = Nothing +cp1_infinity_not_in_first_chart_test = Refl + +-- C^2 and C^3 are different types because the coordinate count is part of the +-- type. This compiler-refusal fixture guards that distinction. +failing "Mismatch between" + complex_dimension_mismatch : ComplexCoordinates ExactComplex 3 + complex_dimension_mismatch = + ComplexCoordinate complex_one $ + ComplexCoordinate complex_i NoComplexCoordinates + +main : IO () +main = putStrLn "complex/projective structural semantics: PASS" diff --git a/_/fixtures/complex-projective/float32.json b/_/fixtures/complex-projective/float32.json new file mode 100644 index 0000000000..bfe8e63de8 --- /dev/null +++ b/_/fixtures/complex-projective/float32.json @@ -0,0 +1,127 @@ +{ + "schema": "idric-complex-projective-corpus-v1", + "precision": { + "name": "Float32", + "epsilon": 1.1920928955078125e-7, + "rounding": "round-to-nearest-even at stored binary32 operation boundaries" + }, + "complex": { + "add": { + "left": [1.25, -2.0], + "right": [0.5, 3.0], + "expected": [1.75, 1.0], + "comparison": "exact-binary32" + }, + "multiply": { + "left": [1.25, -2.0], + "right": [0.5, 3.0], + "expected": [6.625, 2.75], + "comparison": "exact-binary32" + }, + "reciprocal": { + "value": [3.0, 4.0], + "expected": [0.12, -0.16], + "comparison": "floating" + }, + "divide": { + "numerator": [1.0, 2.0], + "denominator": [3.0, -4.0], + "expected": [-0.2, 0.4], + "comparison": "floating" + }, + "conjugate": { + "value": [1.25, -2.0], + "expected": [1.25, 2.0], + "comparison": "exact-binary32" + }, + "magnitude_squared": { + "value": [1.25, -2.0], + "expected": 5.5625, + "comparison": "exact-binary32" + }, + "power_two": { + "value": [0.5, -0.25], + "expected": [0.1875, -0.25], + "comparison": "exact-binary32" + }, + "polynomial": { + "value": [0.5, -0.25], + "coefficients_low_to_high": [[1.0, 0.0], [2.0, 0.0], [1.0, 0.0]], + "expected": [2.1875, -0.75], + "comparison": "exact-binary32" + }, + "rational": { + "value": [0.5, -0.25], + "zero": [-0.35, 0.2], + "pole": [0.4, -0.25], + "expected": [8.5, -4.5], + "comparison": "floating" + }, + "exponential": { + "value": [0.125, 0.25], + "expected_oracle": [1.0979216118186494, 0.2803454137118708], + "implementation": { + "kind": "complex-taylor", + "degree": 7, + "maximum_input_magnitude": 0.5 + }, + "comparison": "bounded-analytic-approximation" + }, + "polar_round_trip": { + "cartesian": [1.0, 1.0], + "expected_magnitude_oracle": 1.4142135623730951, + "expected_phase_turns": 0.125, + "comparison": "floating" + } + }, + "projective": { + "equivalent_real_scale_cp2": { + "left": [[1.0, 0.0], [0.0, 1.0], [2.0, 0.0]], + "scale": [2.0, 0.0], + "right": [[2.0, 0.0], [0.0, 2.0], [4.0, 0.0]], + "expected_equivalent": true + }, + "equivalent_phase_scale_cp2": { + "left": [[1.0, 0.0], [0.0, 1.0], [2.0, 0.0]], + "scale": [0.0, 1.0], + "right": [[0.0, 1.0], [-1.0, 0.0], [0.0, 2.0]], + "expected_equivalent": true + }, + "non_equivalent_cp2": { + "left": [[1.0, 0.0], [0.0, 1.0], [2.0, 0.0]], + "right": [[2.0, 0.0], [0.0, 1.0], [4.0, 0.0]], + "expected_equivalent": false + }, + "affine_chart_cp1": { + "affine": [[0.5, -0.25]], + "embedded": [[1.0, 0.0], [0.5, -0.25]], + "expected_round_trip": [[0.5, -0.25]] + }, + "infinity_cp1": { + "representative": [[0.0, 0.0], [1.0, 0.0]], + "first_chart_defined": false + } + }, + "render": { + "width": 32, + "height": 32, + "viewport": { + "left": -1.0, + "right": 1.0, + "bottom": -1.0, + "top": 1.0 + }, + "divisor": { + "zeros": [[-0.35, 0.2]], + "poles": [[0.4, -0.25]] + }, + "entire_q": { + "constant": [0.0, 0.0], + "linear": [0.125, 0.0], + "quadratic": [0.03125, 0.0] + }, + "field": "f(z)=R(z)*exp(q(z))", + "coloring": "phase-sensitive-rgb-v1", + "cross_backend_pixel_equality_required": false + } +} diff --git a/_/tests/idris2/basic/edric009/expected b/_/tests/idris2/basic/edric009/expected index 69ef4d8eb3..b5fe2a7d2d 100644 --- a/_/tests/idris2/basic/edric009/expected +++ b/_/tests/idris2/basic/edric009/expected @@ -4,3 +4,4 @@ invalid contractions rejected by the compiler: PASS finite presheaf restriction laws: PASS provenance-aware named fact lookup: PASS quadratic and Hermitian form semantics: PASS +complex/projective structural semantics: PASS diff --git a/_/tests/idris2/basic/edric009/run b/_/tests/idris2/basic/edric009/run index 99b561e670..eb8b751eb0 100755 --- a/_/tests/idris2/basic/edric009/run +++ b/_/tests/idris2/basic/edric009/run @@ -13,8 +13,10 @@ cp "$example_dir/TopologyFacts.idric" "$fixture_dir/TopologyFacts.idric" cp "$example_dir/PresheafRestriction.idric" "$fixture_dir/PresheafRestriction.idric" cp "$example_dir/NamedFacts.idric" "$fixture_dir/NamedFacts.idric" cp "$example_dir/QuadraticForms.idric" "$fixture_dir/QuadraticForms.idric" +cp "$example_dir/ComplexProjective.idric" "$fixture_dir/ComplexProjective.idric" cp "$example_dir/Tests.idric" "$fixture_dir/Tests.idric" cp "$example_dir/FormTests.idric" "$fixture_dir/FormTests.idric" +cp "$example_dir/ComplexProjectiveTests.idric" "$fixture_dir/ComplexProjectiveTests.idric" # Preserve .idric all the way into the bootstrapped compiler. The previous # geometry runner renamed its sources to .idr; this receipt exercises the @@ -45,4 +47,16 @@ cp "$example_dir/FormTests.idric" "$fixture_dir/FormTests.idric" fi ./build/exec/quadratic-hermitian-forms + + if ! "$idris2" --check ComplexProjectiveTests.idric >complex-projective-typecheck.log 2>&1; then + cat complex-projective-typecheck.log >&2 + exit 1 + fi + + if ! "$idris2" ComplexProjectiveTests.idric -o complex-projective-semantics >complex-projective-build.log 2>&1; then + cat complex-projective-build.log >&2 + exit 1 + fi + + ./build/exec/complex-projective-semantics ) From 559fc1c14d6826e9be2909ea5c52a74c91d25277 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 8 Sep 2026 21:31:18 -0400 Subject: [PATCH 54/80] Make complex dimension acceptance diagnostic-independent --- .../ComplexProjectiveTests.idric | 23 +++++++++++++------ 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/_/examples/unified-higher-mathematics/ComplexProjectiveTests.idric b/_/examples/unified-higher-mathematics/ComplexProjectiveTests.idric index 69c9acdd15..d464b2e4c0 100644 --- a/_/examples/unified-higher-mathematics/ComplexProjectiveTests.idric +++ b/_/examples/unified-higher-mathematics/ComplexProjectiveTests.idric @@ -95,13 +95,22 @@ cp1_infinity_not_in_first_chart_test : cp1_infinity = Nothing cp1_infinity_not_in_first_chart_test = Refl --- C^2 and C^3 are different types because the coordinate count is part of the --- type. This compiler-refusal fixture guards that distinction. -failing "Mismatch between" - complex_dimension_mismatch : ComplexCoordinates ExactComplex 3 - complex_dimension_mismatch = - ComplexCoordinate complex_one $ - ComplexCoordinate complex_i NoComplexCoordinates +-- Dimension is carried by the result type itself. Keep this acceptance +-- diagnostic-independent: the constructors below inhabit C^2 exactly, while a +-- C^3 consumer cannot accept this value without a type error. +complex_dimension_two_value : ComplexCoordinates ExactComplex 2 +complex_dimension_two_value = + ComplexCoordinate complex_one $ + ComplexCoordinate complex_i NoComplexCoordinates + +complex_dimension_two_identity : + ComplexCoordinates ExactComplex 2 → ComplexCoordinates ExactComplex 2 +complex_dimension_two_identity coordinates = coordinates + +complex_dimension_index_test : + complex_dimension_two_identity complex_dimension_two_value = + complex_dimension_two_value +complex_dimension_index_test = Refl main : IO () main = putStrLn "complex/projective structural semantics: PASS" From a84e491b6be57d46687bd52f4bbe7b567cb21988 Mon Sep 17 00:00:00 2001 From: i Date: Wed, 9 Sep 2026 08:05:25 -0400 Subject: [PATCH 55/80] Repair quadratic-form acceptance blockers --- .../unified-higher-mathematics/FormTests.idric | 4 ++-- .../QuadraticForms.idric | 16 ++++++++-------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/_/examples/unified-higher-mathematics/FormTests.idric b/_/examples/unified-higher-mathematics/FormTests.idric index 782093be1b..f486912cf0 100644 --- a/_/examples/unified-higher-mathematics/FormTests.idric +++ b/_/examples/unified-higher-mathematics/FormTests.idric @@ -286,12 +286,12 @@ sheared_hermitian_gram = standard_hermitian_gram_test : hermitian_gram_entries standard_hermitian_gram = - HermitianMatrix2 1 complex_zero 1 + HermitianEntries2 1 complex_zero 1 standard_hermitian_gram_test = Refl sheared_hermitian_gram_test : hermitian_gram_entries sheared_hermitian_gram = - HermitianMatrix2 1 complex_i 2 + HermitianEntries2 1 complex_i 2 sheared_hermitian_gram_test = Refl conjugate_transpose_change_of_basis_test : diff --git a/_/examples/unified-higher-mathematics/QuadraticForms.idric b/_/examples/unified-higher-mathematics/QuadraticForms.idric index 59e68a0426..c9cc9dbf26 100644 --- a/_/examples/unified-higher-mathematics/QuadraticForms.idric +++ b/_/examples/unified-higher-mathematics/QuadraticForms.idric @@ -47,8 +47,8 @@ zero_covector : {space : FiniteSpace} → ExactVectorSample space → ExactCovectorSample space -zero_covector {space} (UnsafeVectorCoordinates coordinates) = - UnsafeCovectorCoordinates $ unsafe_zero_coordinates (space_rank space) +zero_covector (UnsafeVectorCoordinates coordinates) = + UnsafeCovectorCoordinates $ unsafe_scale_coordinates 0 coordinates -- Fixing the first argument gives B(x,-) as an actual covector. No vector is -- silently identified with its dual. @@ -434,9 +434,9 @@ complex_zero_covector : {space : FiniteSpace} → ExactComplexVectorSample space → ExactComplexCovectorSample space -complex_zero_covector {space} (UnsafeComplexVectorCoordinates coordinates) = +complex_zero_covector (UnsafeComplexVectorCoordinates coordinates) = UnsafeComplexCovectorCoordinates $ - unsafe_zero_complex_coordinates (space_rank space) + unsafe_scale_complex_coordinates complex_zero coordinates -- -------------------------------------------------------------------------- -- Sesquilinear and Hermitian forms @@ -918,10 +918,10 @@ data ExactComplexMatrix2 = ComplexMatrix2 ExactComplex ExactComplex ExactComplex ExactComplex export -data HermitianMatrix2 = HermitianMatrix2 ±Number ExactComplex ±Number +data HermitianMatrix2 = HermitianEntries2 ±Number ExactComplex ±Number full_hermitian_matrix : HermitianMatrix2 → ExactComplexMatrix2 -full_hermitian_matrix (HermitianMatrix2 first off_diagonal second) = +full_hermitian_matrix (HermitianEntries2 first off_diagonal second) = ComplexMatrix2 (Complex first 0) off_diagonal @@ -998,7 +998,7 @@ hermitian_gram_matrix : HermitianGramMatrix basis hermitian_gram_matrix form basis = HermitianGram basis $ - HermitianMatrix2 + HermitianEntries2 (real_part $ evaluate_hermitian form (complex_basis_first basis) @@ -1017,7 +1017,7 @@ represented_hermitian_form : HermitianGramMatrix basis → HermitianForm plane_space represented_hermitian_form - (HermitianGram basis (HermitianMatrix2 first off_diagonal second)) = + (HermitianGram basis (HermitianEntries2 first off_diagonal second)) = HermitianSum (HermitianScale first $ HermitianSquare $ complex_basis_dual_first basis) (HermitianSum From e5eaab59beaa9bbfa14fe2118e18cc510cfd531b Mon Sep 17 00:00:00 2001 From: i Date: Wed, 9 Sep 2026 08:35:24 -0400 Subject: [PATCH 56/80] Expose form semantics to proof consumers --- .../QuadraticForms.idric | 207 ++++++++++-------- 1 file changed, 117 insertions(+), 90 deletions(-) diff --git a/_/examples/unified-higher-mathematics/QuadraticForms.idric b/_/examples/unified-higher-mathematics/QuadraticForms.idric index c9cc9dbf26..41afd8eb2d 100644 --- a/_/examples/unified-higher-mathematics/QuadraticForms.idric +++ b/_/examples/unified-higher-mathematics/QuadraticForms.idric @@ -13,7 +13,7 @@ import MathematicalSpaces -- Bilinear, symmetric bilinear, and quadratic forms -- -------------------------------------------------------------------------- -export +public export data BilinearForm : FiniteSpace → Type where BilinearZero : {space : FiniteSpace} → BilinearForm space BilinearTensor : @@ -28,7 +28,7 @@ data BilinearForm : FiniteSpace → Type where {space : FiniteSpace} → ±Number → BilinearForm space → BilinearForm space -export +public export evaluate_bilinear : {space : FiniteSpace} → BilinearForm space → @@ -43,6 +43,7 @@ evaluate_bilinear (BilinearSum first second) left right = evaluate_bilinear (BilinearScale scalar form) left right = scalar * evaluate_bilinear form left right +public export zero_covector : {space : FiniteSpace} → ExactVectorSample space → @@ -52,7 +53,7 @@ zero_covector (UnsafeVectorCoordinates coordinates) = -- Fixing the first argument gives B(x,-) as an actual covector. No vector is -- silently identified with its dual. -export +public export bilinear_covector_at : {space : FiniteSpace} → BilinearForm space → @@ -69,7 +70,7 @@ bilinear_covector_at (BilinearSum first second) vector = bilinear_covector_at (BilinearScale scalar form) vector = scale_covector scalar $ bilinear_covector_at form vector -export +public export data SymmetricBilinearForm : FiniteSpace → Type where SymmetricZero : {space : FiniteSpace} → SymmetricBilinearForm space SymmetricSquare : @@ -89,7 +90,7 @@ data SymmetricBilinearForm : FiniteSpace → Type where {space : FiniteSpace} → ±Number → SymmetricBilinearForm space → SymmetricBilinearForm space -export +public export evaluate_symmetric : {space : FiniteSpace} → SymmetricBilinearForm space → @@ -107,7 +108,7 @@ evaluate_symmetric (SymmetricSum first second) left right = evaluate_symmetric (SymmetricScale scalar form) left right = scalar * evaluate_symmetric form left right -export +public export symmetric_as_bilinear : {space : FiniteSpace} → SymmetricBilinearForm space → @@ -126,7 +127,7 @@ symmetric_as_bilinear (SymmetricSum first second) = symmetric_as_bilinear (SymmetricScale scalar form) = BilinearScale scalar $ symmetric_as_bilinear form -export +public export symmetric_covector_at : {space : FiniteSpace} → SymmetricBilinearForm space → @@ -140,7 +141,7 @@ symmetric_covector_at form vector = -- as the diagonal of an integral symmetric bilinear form. This distinction is -- essential before a future scalar abstraction can honestly include -- characteristic two. -export +public export data QuadraticForm : FiniteSpace → Type where QuadraticZero : {space : FiniteSpace} → QuadraticForm space QuadraticSquare : @@ -161,7 +162,7 @@ data QuadraticForm : FiniteSpace → Type where {space : FiniteSpace} → SymmetricBilinearForm space → QuadraticForm space -export +public export evaluate_quadratic : {space : FiniteSpace} → QuadraticForm space → @@ -179,7 +180,7 @@ evaluate_quadratic (QuadraticScale scalar form) vector = evaluate_quadratic (QuadraticFromSymmetric form) vector = evaluate_symmetric form vector vector -export +public export quadratic_from_symmetric : {space : FiniteSpace} → SymmetricBilinearForm space → @@ -190,7 +191,7 @@ quadratic_from_symmetric = QuadraticFromSymmetric -- q(x+y) - q(x) - q(y). -- For q(v)=B(v,v), it is 2B in the present integral sample. It is therefore -- not advertised as an inverse to quadratic_from_symmetric. -export +public export polar_form : {space : FiniteSpace} → QuadraticForm space → @@ -205,7 +206,7 @@ polar_form (QuadraticScale scalar form) = SymmetricScale scalar $ polar_form form polar_form (QuadraticFromSymmetric form) = SymmetricScale 2 form -export +public export polar_difference : {space : FiniteSpace} → QuadraticForm space → @@ -220,7 +221,7 @@ polar_difference form left right = -- Evidence that an integral quadratic form has an integral symmetric diagonal -- presentation. There is intentionally no constructor for a general -- QuadraticProduct: an odd cross coefficient would require division by two. -export +public export data DiagonalPresentation : {space : FiniteSpace} → QuadraticForm space → Type where SquareHasDiagonalPresentation : @@ -245,7 +246,7 @@ data DiagonalPresentation : DiagonalPresentation form → DiagonalPresentation (QuadraticScale scalar form) -export +public export presented_symmetric_form : {space : FiniteSpace} → {form : QuadraticForm space} → @@ -267,46 +268,48 @@ presented_symmetric_form (ScaleHasDiagonalPresentation scalar form) = -- This Gaussian-integral value is an exact acceptance scalar, not the future -- general complex-number hierarchy. -export +public export data ExactComplex = Complex ±Number ±Number -export +public export complex_zero : ExactComplex complex_zero = Complex 0 0 -export +public export complex_one : ExactComplex complex_one = Complex 1 0 -export +public export complex_i : ExactComplex complex_i = Complex 0 1 -export +public export complex_add : ExactComplex → ExactComplex → ExactComplex complex_add (Complex a b) (Complex c d) = Complex (a + c) (b + d) +public export complex_negate : ExactComplex → ExactComplex complex_negate (Complex real imaginary) = Complex (-real) (-imaginary) -export +public export complex_multiply : ExactComplex → ExactComplex → ExactComplex complex_multiply (Complex a b) (Complex c d) = Complex (a * c - b * d) (a * d + b * c) +public export scale_complex_integral : ±Number → ExactComplex → ExactComplex scale_complex_integral scalar (Complex real imaginary) = Complex (scalar * real) (scalar * imaginary) -export +public export conjugate : ExactComplex → ExactComplex conjugate (Complex real imaginary) = Complex real (-imaginary) -export +public export real_part : ExactComplex → ±Number real_part (Complex real imaginary) = real -export +public export data RawExactComplexCoordinates : CoordinateRank → Type where UnsafeComplexCoordinateNil : RawExactComplexCoordinates Z UnsafeComplexCoordinateCons : @@ -315,7 +318,7 @@ data RawExactComplexCoordinates : CoordinateRank → Type where RawExactComplexCoordinates n → RawExactComplexCoordinates (S n) -export +public export data ExactComplexVectorSample : FiniteSpace → Type where UnsafeComplexVectorCoordinates : {rank : CoordinateRank} → @@ -323,7 +326,7 @@ data ExactComplexVectorSample : FiniteSpace → Type where RawExactComplexCoordinates rank → ExactComplexVectorSample (NamedFiniteSpace name) -export +public export data ExactComplexCovectorSample : FiniteSpace → Type where UnsafeComplexCovectorCoordinates : {rank : CoordinateRank} → @@ -331,12 +334,14 @@ data ExactComplexCovectorSample : FiniteSpace → Type where RawExactComplexCoordinates rank → ExactComplexCovectorSample (NamedFiniteSpace name) +public export unsafe_zero_complex_coordinates : (rank : CoordinateRank) → RawExactComplexCoordinates rank unsafe_zero_complex_coordinates Z = UnsafeComplexCoordinateNil unsafe_zero_complex_coordinates (S n) = UnsafeComplexCoordinateCons complex_zero $ unsafe_zero_complex_coordinates n +public export unsafe_add_complex_coordinates : {rank : CoordinateRank} → RawExactComplexCoordinates rank → @@ -352,6 +357,7 @@ unsafe_add_complex_coordinates (complex_add left right) (unsafe_add_complex_coordinates left_rest right_rest) +public export unsafe_scale_complex_coordinates : {rank : CoordinateRank} → ExactComplex → @@ -366,6 +372,7 @@ unsafe_scale_complex_coordinates (complex_multiply scalar value) (unsafe_scale_complex_coordinates scalar rest) +public export unsafe_pair_complex_coordinates : {rank : CoordinateRank} → RawExactComplexCoordinates rank → @@ -381,7 +388,7 @@ unsafe_pair_complex_coordinates (complex_multiply left right) (unsafe_pair_complex_coordinates left_rest right_rest) -export +public export add_complex_covector : {space : FiniteSpace} → ExactComplexCovectorSample space → @@ -393,7 +400,7 @@ add_complex_covector UnsafeComplexCovectorCoordinates $ unsafe_add_complex_coordinates left right -export +public export scale_complex_covector : {space : FiniteSpace} → ExactComplex → @@ -403,7 +410,7 @@ scale_complex_covector scalar (UnsafeComplexCovectorCoordinates coordinates) = UnsafeComplexCovectorCoordinates $ unsafe_scale_complex_coordinates scalar coordinates -export +public export complex_contract : {space : FiniteSpace} → ExactComplexCovectorSample space → @@ -414,7 +421,7 @@ complex_contract (UnsafeComplexVectorCoordinates vector_coordinates) = unsafe_pair_complex_coordinates covector_coordinates vector_coordinates -export +public export complex_plane_vector : ExactComplex → ExactComplex → ExactComplexVectorSample plane_space complex_plane_vector first second = @@ -422,7 +429,7 @@ complex_plane_vector first second = UnsafeComplexCoordinateCons first $ UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil -export +public export complex_plane_covector : ExactComplex → ExactComplex → ExactComplexCovectorSample plane_space complex_plane_covector first second = @@ -430,6 +437,7 @@ complex_plane_covector first second = UnsafeComplexCoordinateCons first $ UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil +public export complex_zero_covector : {space : FiniteSpace} → ExactComplexVectorSample space → @@ -443,7 +451,7 @@ complex_zero_covector (UnsafeComplexVectorCoordinates coordinates) = -- -------------------------------------------------------------------------- -- Convention: conjugate-linear in the first argument and linear in the second. -export +public export data SesquilinearForm : FiniteSpace → Type where SesquilinearZero : {space : FiniteSpace} → SesquilinearForm space SesquilinearTensor : @@ -458,7 +466,7 @@ data SesquilinearForm : FiniteSpace → Type where {space : FiniteSpace} → ExactComplex → SesquilinearForm space → SesquilinearForm space -export +public export evaluate_sesquilinear : {space : FiniteSpace} → SesquilinearForm space → @@ -477,7 +485,7 @@ evaluate_sesquilinear (SesquilinearSum first second) left right = evaluate_sesquilinear (SesquilinearScale scalar form) left right = complex_multiply scalar $ evaluate_sesquilinear form left right -export +public export data HermitianForm : FiniteSpace → Type where HermitianZero : {space : FiniteSpace} → HermitianForm space HermitianSquare : @@ -496,7 +504,7 @@ data HermitianForm : FiniteSpace → Type where {space : FiniteSpace} → ±Number → HermitianForm space → HermitianForm space -export +public export evaluate_hermitian : {space : FiniteSpace} → HermitianForm space → @@ -527,7 +535,7 @@ evaluate_hermitian (HermitianSum first second) left right = evaluate_hermitian (HermitianScale scalar form) left right = scale_complex_integral scalar $ evaluate_hermitian form left right -export +public export hermitian_as_sesquilinear : {space : FiniteSpace} → HermitianForm space → @@ -553,7 +561,7 @@ hermitian_as_sesquilinear (HermitianScale scalar form) = -- H(v,v) is real for values built by the closed Hermitian constructors. The -- exact sample exposes that real quantity as ±Number rather than pretending -- that H is an ordinary complex QuadraticForm. -export +public export hermitian_quadratic_quantity : {space : FiniteSpace} → HermitianForm space → @@ -564,7 +572,7 @@ hermitian_quadratic_quantity form vector = -- H(x,-) is a linear complex covector. As a map from x into the dual, this is -- conjugate-linear under the convention above. -export +public export hermitian_covector_at : {space : FiniteSpace} → HermitianForm space → @@ -600,53 +608,53 @@ hermitian_covector_at (HermitianScale scalar form) vector = -- Evidence-bearing refinements on the exact plane sample -- -------------------------------------------------------------------------- -export +public export plane_x : ExactCovectorSample plane_space plane_x = plane_covector 1 0 -export +public export plane_y : ExactCovectorSample plane_space plane_y = plane_covector 0 1 -export +public export plane_positive_quadratic : QuadraticForm plane_space plane_positive_quadratic = QuadraticSum (QuadraticSquare plane_x) (QuadraticSquare plane_y) -export +public export plane_negative_quadratic : QuadraticForm plane_space plane_negative_quadratic = QuadraticScale (-1) plane_positive_quadratic -export +public export plane_first_square : QuadraticForm plane_space plane_first_square = QuadraticSquare plane_x -export +public export plane_negative_first_square : QuadraticForm plane_space plane_negative_first_square = QuadraticScale (-1) plane_first_square -export +public export plane_difference_of_squares : QuadraticForm plane_space plane_difference_of_squares = QuadraticSum (QuadraticSquare plane_x) (QuadraticScale (-1) $ QuadraticSquare plane_y) -export +public export plane_cross_quadratic : QuadraticForm plane_space plane_cross_quadratic = QuadraticProduct plane_x plane_y -export +public export data PositiveDefinite : {space : FiniteSpace} → QuadraticForm space → Type where PlaneSumOfSquaresPositive : PositiveDefinite plane_positive_quadratic -export +public export data NegativeDefinite : {space : FiniteSpace} → QuadraticForm space → Type where NegativePlaneSumOfSquares : NegativeDefinite plane_negative_quadratic -export +public export data PositiveSemidefinite : {space : FiniteSpace} → QuadraticForm space → Type where PositiveDefiniteIsSemidefinite : @@ -655,7 +663,7 @@ data PositiveSemidefinite : PositiveDefinite form → PositiveSemidefinite form PlaneFirstSquareSemidefinite : PositiveSemidefinite plane_first_square -export +public export data NegativeSemidefinite : {space : FiniteSpace} → QuadraticForm space → Type where NegativeDefiniteIsSemidefinite : @@ -665,7 +673,7 @@ data NegativeSemidefinite : NegativePlaneFirstSquareSemidefinite : NegativeSemidefinite plane_negative_first_square -export +public export data QuadraticNondegenerate : {space : FiniteSpace} → QuadraticForm space → Type where PositiveDefiniteIsNondegenerate : @@ -679,22 +687,22 @@ data QuadraticNondegenerate : PlaneDifferenceOfSquaresNondegenerate : QuadraticNondegenerate plane_difference_of_squares -export +public export data QuadraticDegenerate : {space : FiniteSpace} → QuadraticForm space → Type where PlaneFirstSquareDegenerate : QuadraticDegenerate plane_first_square -export +public export data Indefinite : {space : FiniteSpace} → QuadraticForm space → Type where PlaneDifferenceOfSquaresIndefinite : Indefinite plane_difference_of_squares -export +public export data Isotropic : {space : FiniteSpace} → QuadraticForm space → Type where PlaneDifferenceOfSquaresIsotropic : Isotropic plane_difference_of_squares -export +public export data Anisotropic : {space : FiniteSpace} → QuadraticForm space → Type where PositiveDefiniteIsAnisotropic : @@ -709,14 +717,14 @@ data Anisotropic : -- Every ordinary quadratic form in this exact slice is integral-valued on its -- represented lattice. Do not generalize this certificate to a future real or -- complex carrier without an explicit lattice. -export +public export data IntegralQuadratic : {space : FiniteSpace} → QuadraticForm space → Type where ExactIntegralValued : {space : FiniteSpace} → (form : QuadraticForm space) → IntegralQuadratic form -export +public export data EvenQuadratic : {space : FiniteSpace} → QuadraticForm space → Type where TwiceIntegralFormIsEven : @@ -724,7 +732,7 @@ data EvenQuadratic : (form : QuadraticForm space) → EvenQuadratic (QuadraticScale 2 form) -export +public export positive_definite_is_nondegenerate : {space : FiniteSpace} → {form : QuadraticForm space} → @@ -733,7 +741,7 @@ positive_definite_is_nondegenerate : positive_definite_is_nondegenerate evidence = PositiveDefiniteIsNondegenerate evidence -export +public export positive_definite_is_anisotropic : {space : FiniteSpace} → {form : QuadraticForm space} → @@ -742,7 +750,7 @@ positive_definite_is_anisotropic : positive_definite_is_anisotropic evidence = PositiveDefiniteIsAnisotropic evidence -export +public export positive_definite_is_semidefinite : {space : FiniteSpace} → {form : QuadraticForm space} → @@ -751,26 +759,26 @@ positive_definite_is_semidefinite : positive_definite_is_semidefinite evidence = PositiveDefiniteIsSemidefinite evidence -export +public export complex_x : ExactComplexCovectorSample plane_space complex_x = complex_plane_covector complex_one complex_zero -export +public export complex_y : ExactComplexCovectorSample plane_space complex_y = complex_plane_covector complex_zero complex_one -export +public export plane_standard_hermitian : HermitianForm plane_space plane_standard_hermitian = HermitianSum (HermitianSquare complex_x) (HermitianSquare complex_y) -export +public export data HermitianPositiveDefinite : {space : FiniteSpace} → HermitianForm space → Type where StandardComplexPlanePositive : HermitianPositiveDefinite plane_standard_hermitian -export +public export data HermitianNondegenerate : {space : FiniteSpace} → HermitianForm space → Type where HermitianPositiveIsNondegenerate : @@ -778,7 +786,7 @@ data HermitianNondegenerate : {form : HermitianForm space} → HermitianPositiveDefinite form → HermitianNondegenerate form -export +public export hermitian_positive_is_nondegenerate : {space : FiniteSpace} → {form : HermitianForm space} → @@ -793,20 +801,22 @@ hermitian_positive_is_nondegenerate evidence = -- There is not yet a general Basis/Matrix ontology. These local representation -- types establish the abstraction boundary without defining a form as a matrix. -export +public export data IntegralMatrix2 = Matrix2 ±Number ±Number ±Number ±Number -export +public export data SymmetricIntegralMatrix2 = SymmetricMatrix2 ±Number ±Number ±Number -export +public export full_symmetric_matrix : SymmetricIntegralMatrix2 → IntegralMatrix2 full_symmetric_matrix (SymmetricMatrix2 first off_diagonal second) = Matrix2 first off_diagonal off_diagonal second +public export transpose_integral_matrix : IntegralMatrix2 → IntegralMatrix2 transpose_integral_matrix (Matrix2 a b c d) = Matrix2 a c b d +public export multiply_integral_matrix : IntegralMatrix2 → IntegralMatrix2 → IntegralMatrix2 multiply_integral_matrix (Matrix2 a b c d) @@ -817,34 +827,38 @@ multiply_integral_matrix (c * e + d * g) (c * f + d * h) -export +public export data PlaneBasis = StandardPlaneBasis | ShearedPlaneBasis +public export basis_first : PlaneBasis → ExactVectorSample plane_space basis_first StandardPlaneBasis = plane_vector 1 0 basis_first ShearedPlaneBasis = plane_vector 1 0 +public export basis_second : PlaneBasis → ExactVectorSample plane_space basis_second StandardPlaneBasis = plane_vector 0 1 basis_second ShearedPlaneBasis = plane_vector 1 1 +public export basis_dual_first : PlaneBasis → ExactCovectorSample plane_space basis_dual_first StandardPlaneBasis = plane_covector 1 0 basis_dual_first ShearedPlaneBasis = plane_covector 1 (-1) +public export basis_dual_second : PlaneBasis → ExactCovectorSample plane_space basis_dual_second StandardPlaneBasis = plane_covector 0 1 basis_dual_second ShearedPlaneBasis = plane_covector 0 1 -export +public export data GramMatrix : PlaneBasis → Type where Gram : (basis : PlaneBasis) → SymmetricIntegralMatrix2 → GramMatrix basis -export +public export gram_entries : {basis : PlaneBasis} → GramMatrix basis → SymmetricIntegralMatrix2 gram_entries (Gram basis matrix) = matrix -export +public export gram_matrix : SymmetricBilinearForm plane_space → (basis : PlaneBasis) → @@ -856,7 +870,7 @@ gram_matrix form basis = (evaluate_symmetric form (basis_first basis) (basis_second basis)) (evaluate_symmetric form (basis_second basis) (basis_second basis)) -export +public export represented_symmetric_form : {basis : PlaneBasis} → GramMatrix basis → @@ -870,7 +884,7 @@ represented_symmetric_form SymmetricPair (basis_dual_first basis) (basis_dual_second basis)) (SymmetricScale second $ SymmetricSquare $ basis_dual_second basis)) -export +public export represented_quadratic_form : {basis : PlaneBasis} → GramMatrix basis → @@ -878,13 +892,14 @@ represented_quadratic_form : represented_quadratic_form gram = quadratic_from_symmetric $ represented_symmetric_form gram +public export basis_change_matrix : PlaneBasis → PlaneBasis → IntegralMatrix2 basis_change_matrix StandardPlaneBasis StandardPlaneBasis = Matrix2 1 0 0 1 basis_change_matrix StandardPlaneBasis ShearedPlaneBasis = Matrix2 1 1 0 1 basis_change_matrix ShearedPlaneBasis StandardPlaneBasis = Matrix2 1 (-1) 0 1 basis_change_matrix ShearedPlaneBasis ShearedPlaneBasis = Matrix2 1 0 0 1 -export +public export congruence_from : {old_basis : PlaneBasis} → GramMatrix old_basis → @@ -897,14 +912,14 @@ congruence_from (Gram old_basis matrix) new_basis = (full_symmetric_matrix matrix) in multiply_integral_matrix left change -export +public export plane_weighted_symmetric : SymmetricBilinearForm plane_space plane_weighted_symmetric = SymmetricSum (SymmetricScale 2 $ SymmetricSquare plane_x) (SymmetricScale 3 $ SymmetricSquare plane_y) -export +public export plane_weighted_quadratic : QuadraticForm plane_space plane_weighted_quadratic = quadratic_from_symmetric plane_weighted_symmetric @@ -913,13 +928,14 @@ plane_weighted_quadratic = -- Basis-dependent Hermitian representations -- -------------------------------------------------------------------------- -export +public export data ExactComplexMatrix2 = ComplexMatrix2 ExactComplex ExactComplex ExactComplex ExactComplex -export +public export data HermitianMatrix2 = HermitianEntries2 ±Number ExactComplex ±Number +public export full_hermitian_matrix : HermitianMatrix2 → ExactComplexMatrix2 full_hermitian_matrix (HermitianEntries2 first off_diagonal second) = ComplexMatrix2 @@ -928,13 +944,16 @@ full_hermitian_matrix (HermitianEntries2 first off_diagonal second) = (conjugate off_diagonal) (Complex second 0) +public export transpose_complex_matrix : ExactComplexMatrix2 → ExactComplexMatrix2 transpose_complex_matrix (ComplexMatrix2 a b c d) = ComplexMatrix2 a c b d +public export conjugate_transpose_complex_matrix : ExactComplexMatrix2 → ExactComplexMatrix2 conjugate_transpose_complex_matrix (ComplexMatrix2 a b c d) = ComplexMatrix2 (conjugate a) (conjugate c) (conjugate b) (conjugate d) +public export multiply_complex_matrix : ExactComplexMatrix2 → ExactComplexMatrix2 → ExactComplexMatrix2 multiply_complex_matrix @@ -946,9 +965,10 @@ multiply_complex_matrix (complex_add (complex_multiply c e) (complex_multiply d g)) (complex_add (complex_multiply c f) (complex_multiply d h)) -export +public export data ComplexPlaneBasis = StandardComplexBasis | ComplexShearedBasis +public export complex_basis_first : ComplexPlaneBasis → ExactComplexVectorSample plane_space complex_basis_first StandardComplexBasis = @@ -956,6 +976,7 @@ complex_basis_first StandardComplexBasis = complex_basis_first ComplexShearedBasis = complex_plane_vector complex_one complex_zero +public export complex_basis_second : ComplexPlaneBasis → ExactComplexVectorSample plane_space complex_basis_second StandardComplexBasis = @@ -963,6 +984,7 @@ complex_basis_second StandardComplexBasis = complex_basis_second ComplexShearedBasis = complex_plane_vector complex_i complex_one +public export complex_basis_dual_first : ComplexPlaneBasis → ExactComplexCovectorSample plane_space complex_basis_dual_first StandardComplexBasis = @@ -970,6 +992,7 @@ complex_basis_dual_first StandardComplexBasis = complex_basis_dual_first ComplexShearedBasis = complex_plane_covector complex_one (Complex 0 (-1)) +public export complex_basis_dual_second : ComplexPlaneBasis → ExactComplexCovectorSample plane_space complex_basis_dual_second StandardComplexBasis = @@ -977,21 +1000,21 @@ complex_basis_dual_second StandardComplexBasis = complex_basis_dual_second ComplexShearedBasis = complex_plane_covector complex_zero complex_one -export +public export data HermitianGramMatrix : ComplexPlaneBasis → Type where HermitianGram : (basis : ComplexPlaneBasis) → HermitianMatrix2 → HermitianGramMatrix basis -export +public export hermitian_gram_entries : {basis : ComplexPlaneBasis} → HermitianGramMatrix basis → HermitianMatrix2 hermitian_gram_entries (HermitianGram basis matrix) = matrix -export +public export hermitian_gram_matrix : HermitianForm plane_space → (basis : ComplexPlaneBasis) → @@ -1011,7 +1034,7 @@ hermitian_gram_matrix form basis = (complex_basis_second basis) (complex_basis_second basis)) -export +public export represented_hermitian_form : {basis : ComplexPlaneBasis} → HermitianGramMatrix basis → @@ -1028,6 +1051,7 @@ represented_hermitian_form (HermitianScale second $ HermitianSquare $ complex_basis_dual_second basis)) +public export complex_basis_change_matrix : ComplexPlaneBasis → ComplexPlaneBasis → ExactComplexMatrix2 complex_basis_change_matrix StandardComplexBasis StandardComplexBasis = @@ -1039,7 +1063,7 @@ complex_basis_change_matrix ComplexShearedBasis StandardComplexBasis = complex_basis_change_matrix ComplexShearedBasis ComplexShearedBasis = ComplexMatrix2 complex_one complex_zero complex_zero complex_one -export +public export hermitian_congruence_from : {old_basis : ComplexPlaneBasis} → HermitianGramMatrix old_basis → @@ -1054,7 +1078,7 @@ hermitian_congruence_from (HermitianGram old_basis matrix) new_basis = -- Kept only as a negative oracle: ordinary transpose is not the Hermitian -- basis-change operation. -export +public export ordinary_transpose_congruence_oracle : {old_basis : ComplexPlaneBasis} → HermitianGramMatrix old_basis → @@ -1076,31 +1100,34 @@ ordinary_transpose_congruence_oracle -- The current named vector sample is integral. This tiny F2 model keeps a real -- characteristic-two counterexample in compiler acceptance: q(x,y)=xy is -- nonzero while the diagonal of its polar form is always zero. -export +public export data F2 = F2Zero | F2One +public export f2_add : F2 → F2 → F2 f2_add F2Zero value = value f2_add value F2Zero = value f2_add F2One F2One = F2Zero +public export f2_multiply : F2 → F2 → F2 f2_multiply F2Zero value = F2Zero f2_multiply value F2Zero = F2Zero f2_multiply F2One F2One = F2One -export +public export data F2Plane = F2Vector F2 F2 +public export f2_vector_add : F2Plane → F2Plane → F2Plane f2_vector_add (F2Vector a b) (F2Vector c d) = F2Vector (f2_add a c) (f2_add b d) -export +public export f2_cross_quadratic : F2Plane → F2 f2_cross_quadratic (F2Vector x y) = f2_multiply x y -export +public export f2_polar : F2Plane → F2Plane → F2 f2_polar left right = f2_add From a5c639e528150f7ddb8e1d96b8cd51eeba03ed32 Mon Sep 17 00:00:00 2001 From: i Date: Thu, 10 Sep 2026 04:42:45 -0400 Subject: [PATCH 57/80] Fix nounset-safe test prefix guard --- _/tests/testutils.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_/tests/testutils.sh b/_/tests/testutils.sh index 52c22d8f72..3c14cc57ae 100755 --- a/_/tests/testutils.sh +++ b/_/tests/testutils.sh @@ -134,7 +134,7 @@ else fi # Set variables for hygiene testing -if [ -z "$PREFIX_CHANGED" ] && [ -n "$IDRIS2_PREFIX" ]; then +if [ -z "${PREFIX_CHANGED:-}" ] && [ -n "$IDRIS2_PREFIX" ]; then OLD_PREFIX="$IDRIS2_PREFIX" NEW_PREFIX="$test_dir/prefix" From 7e27052ca862853bfe976c287fe9d7fdb7535943 Mon Sep 17 00:00:00 2001 From: i Date: Thu, 10 Sep 2026 04:42:54 -0400 Subject: [PATCH 58/80] Add compact compiler evidence guardrails (#83) --- AGENTS.md | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/AGENTS.md b/AGENTS.md index 13f7b01099..a217f3be15 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -7,6 +7,9 @@ Before writing or reviewing Idriç-facing source, read: 3. [`examples/intent/http_server/`](examples/intent/http_server/README.md) 4. [`_/AGENTS.md`](_/AGENTS.md) for repository and branch rules +Apply the shared evidence and acceptance guardrails in +`isomorphisms/ai-ci/AGENTS.md`. + `STYLE.md` is the canonical source-style guide. The two intent examples are the canonical structural references. This file is operational guidance; do not copy the full style guide into `AGENTS.md`. @@ -18,5 +21,17 @@ Inspect the relevant surrounding Idriç work before inventing a new pattern, but do not promote arbitrary existing files into style authorities. Human corrections and the canonical guide/examples take precedence. +Do not restore a rejected language ontology under its old name or a near-synonym +because it survives in inherited code, generated output, an old branch, or an +upstream convention. Preserve the current semantic distinction first. + +For compiler/backend claims, bind evidence to the exact source head and material +compiler/backend pins. Source presence, generated output, compilation, and an +oracle or fallback do not prove execution through the named backend. + +Keep language and mathematical semantics above compiler, ABI, storage, and +machine representations. A convenient representation may implement an object; +it does not define the object unless the language semantics explicitly say so. + Work on a branch, keep changes narrow, and run the checks relevant to the code you changed before proposing it for merge. From a63d6a60557e1cf376fe7c79d8f519dedd3ab033 Mon Sep 17 00:00:00 2001 From: i Date: Thu, 10 Sep 2026 18:37:06 -0400 Subject: [PATCH 59/80] Make test support paths nounset-safe --- _/tests/testutils.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/_/tests/testutils.sh b/_/tests/testutils.sh index 3c14cc57ae..21c0d68657 100755 --- a/_/tests/testutils.sh +++ b/_/tests/testutils.sh @@ -145,8 +145,8 @@ if [ -z "${PREFIX_CHANGED:-}" ] && [ -n "$IDRIS2_PREFIX" ]; then export IDRIS2_PACKAGE_PATH="$OLD_PP$SEP$NEW_PP" # Use TEST_IDRIS2_LIBS and TEST_IDRIS2_DATA to pass locations for # prebuilt libidris2_support and its DATA files. - export IDRIS2_LIBS="$OLD_PP/lib$SEP$NEW_PP/lib$SEP$TEST_IDRIS2_LIBS" - export IDRIS2_DATA="$OLD_PP/support$SEP$NEW_PP/support$SEP$TEST_IDRIS2_DATA" + export IDRIS2_LIBS="$OLD_PP/lib$SEP$NEW_PP/lib$SEP${TEST_IDRIS2_LIBS:-}" + export IDRIS2_DATA="$OLD_PP/support$SEP$NEW_PP/support$SEP${TEST_IDRIS2_DATA:-}" # Set where to install stuff export IDRIS2_PREFIX="$NEW_PREFIX" From 23c3be78d4826f713c79c9387a499b38b4e6e562 Mon Sep 17 00:00:00 2001 From: i Date: Thu, 10 Sep 2026 22:46:05 -0400 Subject: [PATCH 60/80] Remove Cardinality split --- Idris/Desugar.idr | 42 +------ Idris/Parser.idr | 5 - Idris/Pretty.idr | 1 - Idris/Syntax.idr | 5 +- Idris/Syntax/Traversals.idr | 3 - Parser/Lexer/Source.idr | 5 +- Parser/Rule/Source.idr | 9 -- Parser/Source.idr | 7 +- STYLE.md | 21 ++-- _/BRANCHES.md | 4 +- _/EDRIC.md | 47 +++----- _/edric | 1 - .../EuclideanGeometry.idric | 28 ++--- .../HIGH_DIMENSIONAL_VERIFICATION.md | 4 +- .../MathematicalSpaces.idric | 58 +++++----- .../PresheafRestriction.idric | 6 +- .../unified-higher-mathematics/README.md | 6 +- .../unified-higher-mathematics/Tests.idric | 77 +++++++------ .../TopologyFacts.idric | 56 +++------- .../exercise/Main.idric | 2 +- .../expected-diagnostic | 2 +- _/koans/01-values-types-and-holes/holes | 2 +- .../solution/Main.idric | 2 +- .../exercise/Main.idric | 2 +- .../expected | 2 +- .../solution/Main.idric | 2 +- .../exercise/Main.idric | 4 +- .../solution/Main.idric | 2 +- .../07-erased-arguments/expected-diagnostic | 2 +- .../exercise/Main.idric | 2 +- .../solution/Main.idric | 2 +- .../exercise/IdrisCompatibility.idr | 4 +- .../11-source-boundaries/exercise/Main.idric | 2 +- .../solution/IdrisCompatibility.idr | 4 +- .../11-source-boundaries/solution/Main.idric | 2 +- _/koans/12-wegert-model/exercise/Main.idric | 10 +- _/koans/12-wegert-model/solution/Main.idric | 10 +- _/libs/prelude/Prelude/Cast.idr | 14 --- _/libs/prelude/Prelude/Num.idr | 38 ------- _/libs/prelude/Prelude/Ops.idr | 2 - _/libs/prelude/Prelude/Show.idr | 8 -- _/libs/prelude/Prelude/Types.idr | 104 ------------------ _/tests/idris2/basic/edric003/Main.idric | 4 +- .../idris2/basic/edric003/WegertTouch.idric | 10 +- _/tests/idris2/basic/edric005/Main.idric | 6 +- .../basic/edric010/IdrisCompatibility.idr | 10 -- .../basic/edric010/NegativeIsNotNumber.idric | 4 - _/tests/idris2/basic/edric010/Valid.idric | 34 ------ .../basic/edric010/ZeroIsNotNumber.idric | 4 - _/tests/idris2/basic/edric010/expected | 4 - _/tests/idris2/basic/edric010/run | 28 ----- 51 files changed, 174 insertions(+), 539 deletions(-) delete mode 100644 _/tests/idris2/basic/edric010/IdrisCompatibility.idr delete mode 100644 _/tests/idris2/basic/edric010/NegativeIsNotNumber.idric delete mode 100644 _/tests/idris2/basic/edric010/Valid.idric delete mode 100644 _/tests/idris2/basic/edric010/ZeroIsNotNumber.idric delete mode 100644 _/tests/idris2/basic/edric010/expected delete mode 100755 _/tests/idris2/basic/edric010/run diff --git a/Idris/Desugar.idr b/Idris/Desugar.idr index 52c1561ded..cb373f0617 100644 --- a/Idris/Desugar.idr +++ b/Idris/Desugar.idr @@ -129,7 +129,7 @@ checkConflictingFixities isPrefix opn (True, ((fxName, fx) :: _), _) => do -- in the prefix case, remove conflicts with infix (-) - let extraFixities = pre ++ (filter (\(nm, _) => not $ isNegationOperator nm) inf) + let extraFixities = pre ++ (filter (\(nm, _) => not $ nameRoot nm == "-") inf) unless (isCompatible fx extraFixities) $ warnConflict fxName extraFixities pure (mkPrec fx.fix fx.precedence, DeclaredFixity fx) -- Could not find any prefix operator fixities, there may still be conflicts with @@ -138,7 +138,7 @@ checkConflictingFixities isPrefix opn (False, _, ((fxName, fx) :: _)) => do -- In the infix case, remove conflicts with prefix (-) - let extraFixities = (filter (\(nm, _) => not $ isNegationOperator nm) pre) ++ inf + let extraFixities = (filter (\(nm, _) => not $ nm == UN (Basic "-")) pre) ++ inf unless (isCompatible fx extraFixities) $ warnConflict fxName extraFixities pure (mkPrec fx.fix fx.precedence, DeclaredFixity fx) -- Could not find any infix operator fixities, there may be prefix ones @@ -152,9 +152,6 @@ checkConflictingFixities isPrefix opn && fx.precedence == fx'.precedence && fx.bindingInfo == fx'.bindingInfo) . map snd - isNegationOperator : Name -> Bool - isNegationOperator name = nameRoot name == "-" || nameRoot name == "-~-" - -- Emits a warning using the fixity that we picked and the list of all conflicting fixities warnConflict : (picked : Name) -> (conflicts : List (Name, FixityInfo)) -> Core () warnConflict fxName all = @@ -433,33 +430,6 @@ mutual (PLam fc top Explicit (PRef fc (MN "arg" 0)) (PImplicit fc) (POp fc (MkFCVal op.fc $ NoBinder arg) op (PRef fc (MN "arg" 0)))) desugarB side ps (PSearch fc depth) = pure $ Elaborable_Search fc depth - desugarB side ps (PIdricInteger fc value) - = do let vfc = virtualiseFC fc - let literal = Elaborable_Primitive_Value fc (BI value) - let positive = Elaborable_Apply vfc - (Elaborable_Name vfc - (NS typesNS $ UN $ Basic "positiveNumberFromInteger")) - literal - let signed = Elaborable_Apply vfc - (Elaborable_Name vfc - (NS typesNS $ UN $ Basic "SignedValue")) - literal - let cardinality = Elaborable_Apply vfc - (Elaborable_Name vfc - (NS typesNS $ UN $ Basic "cardinalityFromInteger")) - literal - case !fromIntegerName of - Nothing => pure $ Elaborable_Alternative fc FirstSuccess - [positive, signed, cardinality, literal] - Just representationLiteral => - pure $ Elaborable_Alternative fc FirstSuccess - [ positive - , signed - , cardinality - , Elaborable_Apply vfc - (Elaborable_Name vfc representationLiteral) - literal - ] desugarB side ps (PPrimVal fc (BI x)) = case !fromIntegerName of Nothing => @@ -907,18 +877,10 @@ mutual _ => do arg' <- desugarTree side ps (Leaf $ PPrimVal fc c) pure (PApp loc (PRef opFC (UN $ Basic "negate")) arg') - desugarTree side ps (Pre loc opFC (OpSymbols $ UN $ Basic "-~-", _) $ Leaf $ PIdricInteger fc value) - = let newFC = fromMaybe EmptyFC (mergeFC loc fc) - in pure $ PIdricInteger newFC (prim__sub_Integer 0 value) - desugarTree side ps (Pre loc opFC (OpSymbols $ UN $ Basic "-", _) arg) = do arg' <- desugarTree side ps arg pure (PApp loc (PRef opFC (UN $ Basic "negate")) arg') - desugarTree side ps (Pre loc opFC (OpSymbols $ UN $ Basic "-~-", _) arg) - = do arg' <- desugarTree side ps arg - pure (PApp loc (PRef opFC (UN $ Basic "idricNegate")) arg') - desugarTree side ps (Pre loc opFC (op, _) arg) = do arg' <- desugarTree side ps arg pure (PApp loc (PRef opFC op.toName) arg') diff --git a/Idris/Parser.idr b/Idris/Parser.idr index b228eb71eb..c6b3d857c0 100644 --- a/Idris/Parser.idr +++ b/Idris/Parser.idr @@ -125,11 +125,6 @@ atom fname pure (PType (boundToFC fname x)) <|> do x <- bounds $ name pure (PRef (boundToFC fname x) x.val) - <|> the (Rule PTerm) - (do x <- bounds idricIntegerLit - let fc = boundToFC fname x - actD (decorationFromBounded fname Data x) - pure (PIdricInteger {nm = Name} fc x.val)) <|> do x <- bounds $ dependentDecorate fname constant $ \c => if isPrimType c then Typ diff --git a/Idris/Pretty.idr b/Idris/Pretty.idr index 8ac3e3ddcd..d3a4d9b2a9 100644 --- a/Idris/Pretty.idr +++ b/Idris/Pretty.idr @@ -347,7 +347,6 @@ mutual prettyPrec d (PUnquote _ tm) = parenthesise (d > startPrec) $ "~" <+> parens (pretty tm) prettyPrec d (PRunElab _ tm) = parenthesise (d > startPrec) $ pragma "%runElab" <++> pretty tm prettyPrec d (PPrimVal _ c) = pretty c - prettyPrec d (PIdricInteger _ value) = byShow value prettyPrec d (PHole _ _ n) = hole (pretty0 (strCons '?' n)) prettyPrec d (PType _) = annotate (TCon Nothing) "Type" prettyPrec d (PAs _ _ n p) = pretty0 n <+> "@" <+> prettyPrec d p diff --git a/Idris/Syntax.idr b/Idris/Syntax.idr index 4d6c50b2e5..0ac3a8c63c 100644 --- a/Idris/Syntax.idr +++ b/Idris/Syntax.idr @@ -111,7 +111,6 @@ mutual PSearch : FC -> (depth : Nat) -> PTerm' nm PPrimVal : FC -> Constant -> PTerm' nm - PIdricInteger : FC -> Integer -> PTerm' nm PQuote : FC -> PTerm' nm -> PTerm' nm PQuoteName : FC -> Name -> PTerm' nm PQuoteDecl : FC -> List (PDecl' nm) -> PTerm' nm @@ -185,7 +184,6 @@ mutual getPTermLoc (PForce fc _) = fc getPTermLoc (PSearch fc _) = fc getPTermLoc (PPrimVal fc _) = fc - getPTermLoc (PIdricInteger fc _) = fc getPTermLoc (PQuote fc _) = fc getPTermLoc (PQuoteName fc _) = fc getPTermLoc (PQuoteDecl fc _) = fc @@ -913,7 +911,6 @@ parameters {0 nm : Type} (toName : nm -> Name) showPTermPrec d (PUnquote _ tm) = "~(" ++ showPTermPrec d tm ++ ")" showPTermPrec d (PRunElab _ tm) = "%runElab " ++ showPTermPrec d tm showPTermPrec d (PPrimVal _ c) = showPrec d c - showPTermPrec d (PIdricInteger _ value) = show value showPTermPrec _ (PHole _ _ n) = "?" ++ n showPTermPrec _ (PType _) = "Type" showPTermPrec d (PAs _ _ n p) = showPrec d n ++ "@" ++ showPTermPrec d p @@ -1110,7 +1107,6 @@ initSyntax initFixities : ANameMap FixityInfo initFixities = fromList [ (UN $ Basic "-", MkFixityInfo EmptyFC Export NotBinding Prefix 10) - , (UN $ Basic "-~-", MkFixityInfo EmptyFC Export NotBinding Prefix 10) , (UN $ Basic "negate", MkFixityInfo EmptyFC Export NotBinding Prefix 10) -- for documentation purposes , (UN $ Basic "=", MkFixityInfo EmptyFC Export NotBinding Infix 0) ] @@ -1208,3 +1204,4 @@ Show PDeclNoFC where show (PRunElabDecl {}) = "PRunElabDecl" show (PDirective {}) = "PDirective" show (PBuiltin {}) = "PBuiltin" + diff --git a/Idris/Syntax/Traversals.idr b/Idris/Syntax/Traversals.idr index cef993b31e..94192a11c8 100644 --- a/Idris/Syntax/Traversals.idr +++ b/Idris/Syntax/Traversals.idr @@ -77,7 +77,6 @@ mapPTermM f = goPTerm where >>= f goPTerm t@(PSearch {}) = f t goPTerm t@(PPrimVal {}) = f t - goPTerm t@(PIdricInteger {}) = f t goPTerm (PQuote fc x) = PQuote fc <$> goPTerm x >>= f @@ -440,7 +439,6 @@ mapPTerm f = goPTerm where = f $ PForce fc $ goPTerm x goPTerm t@(PSearch {}) = f t goPTerm t@(PPrimVal {}) = f t - goPTerm t@(PIdricInteger {}) = f t goPTerm (PQuote fc x) = f $ PQuote fc $ goPTerm x goPTerm t@(PQuoteName {}) = f t @@ -637,7 +635,6 @@ substFC fc = mapPTerm $ \case PForce _ x => PForce fc x PSearch _ depth => PSearch fc depth PPrimVal _ x => PPrimVal fc x - PIdricInteger _ value => PIdricInteger fc value PQuote _ x => PQuote fc x PQuoteName _ n => PQuoteName fc n PQuoteDecl _ xs => PQuoteDecl fc xs diff --git a/Parser/Lexer/Source.idr b/Parser/Lexer/Source.idr index 2def7610fa..525f53c03c 100644 --- a/Parser/Lexer/Source.idr +++ b/Parser/Lexer/Source.idr @@ -26,7 +26,7 @@ public export data SourceSyntax = IdrisSyntax | IdricSyntax isIdricSyntaxSymbol : Char -> Bool -isIdricSyntaxSymbol c = c `elem` unpack "→⇒←≤−" +isIdricSyntaxSymbol c = c `elem` unpack "→⇒←≤" public export data DebugInfo @@ -49,7 +49,6 @@ data Token = CharLit String | DoubleLit Double | IntegerLit Integer - | IdricIntegerLit Integer -- String | StringBegin Nat IsMultiline -- The escape depth and whether is multiline string | StringEnd @@ -88,7 +87,6 @@ Show Token where show (CharLit x) = "character " ++ show x show (DoubleLit x) = "double " ++ show x show (IntegerLit x) = "literal " ++ show x - show (IdricIntegerLit x) = "Idriç literal " ++ show x -- String show (StringBegin hashtag Single) = "string begin" show (StringBegin hashtag Multi) = "multiline string begin" @@ -121,7 +119,6 @@ Pretty Void Token where pretty (CharLit x) = pretty "character" <++> squotes (pretty x) pretty (DoubleLit x) = pretty "double" <++> pretty (show x) pretty (IntegerLit x) = pretty "literal" <++> pretty (show x) - pretty (IdricIntegerLit x) = pretty "Idriç literal" <++> pretty (show x) -- String pretty (StringBegin hashtag Single) = reflow "string begin" pretty (StringBegin hashtag Multi) = reflow "multiline string begin" diff --git a/Parser/Rule/Source.idr b/Parser/Rule/Source.idr index 93eb173b26..1708debeef 100644 --- a/Parser/Rule/Source.idr +++ b/Parser/Rule/Source.idr @@ -126,15 +126,6 @@ intLit = terminal "Expected integer literal" $ \case IntegerLit i => Just i - IdricIntegerLit i => Just i - _ => Nothing - -export -idricIntegerLit : Rule Integer -idricIntegerLit - = terminal "Expected Idriç integer literal" $ - \case - IdricIntegerLit i => Just i _ => Nothing export diff --git a/Parser/Source.idr b/Parser/Source.idr index 79dd1a6b5b..3d51eafe67 100644 --- a/Parser/Source.idr +++ b/Parser/Source.idr @@ -30,12 +30,9 @@ canonicalize_idric_namespace ns canonicalize_idric_token : Token -> Token canonicalize_idric_token (Ident "choice") = Keyword "choice" -canonicalize_idric_token (IntegerLit value) = IdricIntegerLit value -canonicalize_idric_token (Symbol "+") = Symbol "+~+" -canonicalize_idric_token (Symbol "*") = Symbol "*~*" -canonicalize_idric_token (Symbol "-") = Symbol "-~-" -canonicalize_idric_token (Symbol "−") = Symbol "-~-" +canonicalize_idric_token (Ident "Number") = Ident "Nat" canonicalize_idric_token (Ident "Text") = Ident "String" +canonicalize_idric_token (Ident "ℕ") = Ident "Nat" canonicalize_idric_token (DotSepIdent ns "Text") = if unsafeUnfoldNamespace ns == ["Data"] then DotSepIdent ns "String" diff --git a/STYLE.md b/STYLE.md index 3b0549c399..38c3775398 100644 --- a/STYLE.md +++ b/STYLE.md @@ -24,12 +24,10 @@ able to re-export; it is not a ceremonial prefix for every definition. - Use `snake_case` for names under our control and prefer complete domain words to conventional Haskell abbreviations. -- Use `Number` for ordinary positive whole numbers beginning at one, and - `±Number` for ordinary signed whole numbers, including zero. Do not use - `Nat`, `Natural`, `Int`, `Integer`, or the retired migration spelling `ℕ` as - programmer-facing synonyms for these Idriç types. Use `Text`, not `String`, - for decoded character text, and import `Data.Text` for inherited text - operations. Bootstrap and representation code may retain its native names. +- Use `Number`, not `Nat` or the older migration spelling `ℕ`, in new `.idric` + source. Use `Text`, not `String`, for decoded character text, and import + `Data.Text` for inherited text operations. These spellings lower to inherited + representations inside the bootstrap compiler. - Use a semantic type instead of `Number`, `Text`, a raw integer, `Bits8`, or a flag when the value has narrower operations or invariants. - Use `List` for an ordinary sequence, `SizedList` or `ListOfLength` when length @@ -42,14 +40,9 @@ able to re-export; it is not a ceremonial prefix for every definition. - Avoid gratuitous currying, bare-application chains, constructor-led program descriptions, and implementation types in domain vocabulary. -`Number` excludes zero. `±Number` admits negative values, zero, and positive -values, and positive `Number` values widen to it when an operation requires -the broader type. Subtracting one `Number` from another therefore produces a -`±Number`; addition and multiplication preserve `Number`. Use `Cardinality` -for a zero-capable count, length, rank, or size when that is the value's actual -meaning. Prefer a still more specific domain type when its operations or -invariants differ. Do not add `Positive Number` as a verbose synonym or a -fundamental `Negative Number` merely for symmetry. +The general name for a number that may be positive or negative is still +unresolved. Prefer a domain name where there is one and do not introduce a new +unrestricted wrapper merely to avoid inherited spelling. ## Semantic boundaries diff --git a/_/BRANCHES.md b/_/BRANCHES.md index d6600cd18d..254c73f860 100644 --- a/_/BRANCHES.md +++ b/_/BRANCHES.md @@ -1,6 +1,6 @@ # Idriç branch map -This map records the branch topology as of 2026-09-08. It exists to prevent an +This map records the branch topology as of 2026-08-27. It exists to prevent an old Idris bootstrap, a backend experiment, or a closed pull-request branch from being mistaken for the current compiler. @@ -28,9 +28,9 @@ These are reviewable changes based on `Idriç`, not alternate compiler roots. | --- | --- | --- | | #6 | `float32-primitive` | Add the 32-bit floating-point primitive | | #10 | `termux-armv7-binary` | Build the compiler for 32-bit ARMv7 Termux | +| #11 | `fix-idric-natural-vocabulary` | Use `ℕ` at the Idriç source boundary | | #13 | `depends-on-syntax` | Restrict `depends on` to dependency declarations | | #19 | `prelude/descriptive-io-names` | Make descriptive I/O names primary | -| #77 | `style/idric-number-text-surface` | Define the active Idriç `Number`, `±Number`, `Text`, and `Data.Text` surface | Preserve these names while their pull requests are open. Delete each head branch after the change is merged or deliberately abandoned. diff --git a/_/EDRIC.md b/_/EDRIC.md index cb62cde004..d5e0c7e44c 100644 --- a/_/EDRIC.md +++ b/_/EDRIC.md @@ -24,30 +24,22 @@ The first Edric-specific syntax is the storage-neutral `choice` declaration desc ## Number and text vocabulary -Idriç source spells ordinary positive whole numbers `Number` and ordinary -signed whole numbers `±Number`. `Number` begins at one and excludes zero; -`±Number` includes negative values, zero, and positive values. The latter is -valid source notation in a type position. Ordinary `.idr` source remains -unchanged. Inherited numeric names remain available to compiler, bootstrap, -ABI, and explicit compatibility code, but are not names for new Idriç APIs, -examples, or teaching material. - -Idriç literals are checked against their intended type. Positive literals may -inhabit `Number`, while zero and negative literals cannot. All three kinds may -inhabit `±Number`, and a `Number` can be widened with `numberAsSigned` when an -explicit conversion is useful. Addition and multiplication of `Number` -values remain positive; subtraction returns `±Number`. `Cardinality` names a -zero-capable count, length, rank, or size. These are distinct source meanings -even though the bootstrap uses inherited arbitrary-precision representations. +Idriç source spells the unrestricted nonnegative whole-number type `Number` and +decoded character text `Text`. In a `.idric` file the frontend lowers those +names to the inherited Idris 2 bootstrap representations. Ordinary `.idr` +source remains unchanged. The inherited names are implementation and +compatibility spellings, not names for new Idriç APIs, examples, or teaching +material. Fresh `.idric` source imports `Data.Text` when it needs the inherited text operations. The frontend lowers that exact module boundary to `Data.String`; ordinary `.idr` module names remain unchanged. -`Number`, `±Number`, and `Text` describe general language values. Code should -still use a more specific semantic type—source location, byte count, path, -protocol field, and so on—when operations or invariants differ. The older `ℕ` -input spelling is retired rather than retained as a competing alias. +`Number` and `Text` describe general language values. Code should still use a +more specific semantic type—source location, byte count, path, protocol field, +and so on—when operations or invariants differ. The older `ℕ` input spelling is +accepted temporarily so existing Idriç source can migrate without a flag day; +it is not the current spelling for new source. ## Data-structure vocabulary @@ -75,9 +67,9 @@ snake_case names: ```idris choice existing_touch_target one_of - fixed_value ±Number - zero ±Number - pole ±Number + fixed_value Number + zero Number + pole Number choice touch_beginning one_of near_existing existing_touch_target @@ -228,16 +220,11 @@ A new thread working on Edric should: - Idriç source extension: `.idric`; `.idr` remains accepted for Idris compatibility. - Storage-neutral, lower snake_case `choice ... one_of` syntax: implemented for `.idric` only. - Ordinary `.idr` use of `choice` and `one_of` as identifiers: preserved and regression-tested. -- Idriç source spells positive whole numbers `Number`, signed whole numbers - `±Number`, and decoded character text `Text`. `Number` excludes zero; - `±Number` admits negative values, zero, and positive values. -- Source literals and arithmetic enforce that distinction. `Number - Number` - returns `±Number`, while positive values may be widened deliberately. -- Zero-capable counts, lengths, ranks, and sizes use `Cardinality` or a more - specific domain type rather than being mislabeled as signed values. +- Idriç source spells nonnegative whole numbers `Number` and decoded character + text `Text`; the frontend lowers both to inherited bootstrap representations. - Idriç source spells the inherited text-operation module `Data.Text`; the frontend lowers that exact module boundary to `Data.String`. -- The older `ℕ` spelling is retired at the Idriç source boundary. +- The older `ℕ` spelling remains a migration alias, not the current spelling. - Idriç source accepts `→`, `⇒`, `←`, and `≤` as compact aliases for `->`, `=>`, `<-`, and `<=`; the ASCII spellings remain accepted. - The aliases are filename-scoped to `.idric`; ordinary `.idr` Unicode identifiers remain unchanged. - Canonical Unicode pretty-printing is not yet claimed by this input-syntax slice. diff --git a/_/edric b/_/edric index 2564b4a502..26dcee1b3a 100755 --- a/_/edric +++ b/_/edric @@ -53,7 +53,6 @@ smoke_test() { run_test idris2/basic/edric005 run_test idris2/basic/edric006 run_test idris2/basic/edric009 - run_test idris2/basic/edric010 sh "$repo_root/scripts/test-one-step-emitter.sh" } diff --git a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric index 841bd936ea..d2f412c48b 100644 --- a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric +++ b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric @@ -10,7 +10,7 @@ import MathematicalSpaces public export data EuclideanStructure : FiniteSpace → Type where StandardCoordinate : - {rank : CoordinateRank} → + {rank : Number} → {name : SpaceName rank} → EuclideanStructure (NamedFiniteSpace name) @@ -47,19 +47,19 @@ public export dot : {space : FiniteSpace} → EuclideanStructure space → - ExactVectorSample space → ExactVectorSample space → ±Number + ExactVectorSample space → ExactVectorSample space → Integer dot structure left right = contract (lower_index structure left) right public export squared_norm : {space : FiniteSpace} → - EuclideanStructure space → ExactVectorSample space → ±Number + EuclideanStructure space → ExactVectorSample space → Integer squared_norm structure value = dot structure value value -- SquareRoot is deliberately symbolic. The exact integer radicand remains -- visible, and this small semantic layer makes no floating-point choice. public export -data ExactSquareRoot = SquareRoot ±Number +data ExactSquareRoot = SquareRoot Integer public export norm : @@ -71,7 +71,7 @@ public export squared_distance : {space : FiniteSpace} → EuclideanStructure space → - ExactVectorSample space → ExactVectorSample space → ±Number + ExactVectorSample space → ExactVectorSample space → Integer squared_distance structure left right = squared_norm structure (difference_vector left right) @@ -107,7 +107,7 @@ raise_indexed structure (LowerIndex value) = -- -------------------------------------------------------------------------- public export -data Quaternion = Q ±Number ±Number ±Number ±Number +data Quaternion = Q Integer Integer Integer Integer public export quaternion_negate : Quaternion → Quaternion @@ -127,7 +127,7 @@ quaternion_multiply (Q a b c d) (Q e f g h) = (a * h + b * g - c * f + d * e) public export -quaternion_norm_squared : Quaternion → ±Number +quaternion_norm_squared : Quaternion → Integer quaternion_norm_squared (Q a b c d) = a * a + b * b + c * c + d * d @@ -151,7 +151,7 @@ public export data UnitQuaternion : Type where UnitQuaternionValue : (value : Quaternion) → - quaternion_norm_squared value = the ±Number 1 → + quaternion_norm_squared value = 1 → UnitQuaternion public export @@ -200,14 +200,14 @@ data OrthogonalTransform : {structure : EuclideanStructure space} → OrthogonalTransform structure Preserving FirstAxisReflectionTransform : - {n : CoordinateRank} → + {n : Number} → {name : SpaceName (S n)} → OrthogonalTransform {space = NamedFiniteSpace name} StandardCoordinate Reversing FirstPlaneQuarterTurnTransform : - {n : CoordinateRank} → + {n : Number} → {name : SpaceName (S (S n))} → OrthogonalTransform {space = NamedFiniteSpace name} @@ -236,7 +236,7 @@ data SpecialOrthogonal : public export first_axis_reflection : - {n : CoordinateRank} → + {n : Number} → {name : SpaceName (S n)} → (structure : EuclideanStructure (NamedFiniteSpace name)) → OrthogonalTransform structure Reversing @@ -244,7 +244,7 @@ first_axis_reflection StandardCoordinate = FirstAxisReflectionTransform public export first_plane_quarter_turn : - {n : CoordinateRank} → + {n : Number} → {name : SpaceName (S (S n))} → (structure : EuclideanStructure (NamedFiniteSpace name)) → SpecialOrthogonal structure @@ -354,7 +354,7 @@ apply_special_orthogonal_exact (InSO transform) vector = -- the connected OrthogonalTransform evaluator. public export apply_first_axis_reflection : - {n : CoordinateRank} → + {n : Number} → {name : SpaceName (S n)} → (structure : EuclideanStructure (NamedFiniteSpace name)) → ExactVectorSample (NamedFiniteSpace name) → @@ -364,7 +364,7 @@ apply_first_axis_reflection structure = public export apply_first_plane_quarter_turn : - {n : CoordinateRank} → + {n : Number} → {name : SpaceName (S (S n))} → (structure : EuclideanStructure (NamedFiniteSpace name)) → ExactVectorSample (NamedFiniteSpace name) → diff --git a/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md b/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md index 09f847d038..93c5cdfd8c 100644 --- a/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md +++ b/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md @@ -85,8 +85,8 @@ real bootstrapped Idric path it: 3. executes that program and compares its PASS lines with `expected`. The focused source uses `ExactVectorSample` and `ExactCovectorSample`, making -their exact `±Number` coordinate fragment explicit in the type names. These -values denote exact samples inside the named real coordinate space; they do not define +their `Integer` coordinate fragment explicit in the type names. These values +denote exact samples inside the named real coordinate space; they do not define its complete scalar carrier. The `Refl` declarations check the stated images, squared norms, dot products, involution, fourth-power identity, and the preserved 128th coordinate by compiler normalization. diff --git a/_/examples/unified-higher-mathematics/MathematicalSpaces.idric b/_/examples/unified-higher-mathematics/MathematicalSpaces.idric index 3e0ef0fb33..c885845fce 100644 --- a/_/examples/unified-higher-mathematics/MathematicalSpaces.idric +++ b/_/examples/unified-higher-mathematics/MathematicalSpaces.idric @@ -8,11 +8,7 @@ module MathematicalSpaces -- Rank equality alone is still not space equality. public export -CoordinateRank : Type -CoordinateRank = Cardinality - -public export -data SpaceName : CoordinateRank → Type where +data SpaceName : Number → Type where PlaneName : SpaceName 2 ImagePlaneName : SpaceName 2 RealThreeName : SpaceName 3 @@ -20,10 +16,10 @@ data SpaceName : CoordinateRank → Type where public export data FiniteSpace : Type where - NamedFiniteSpace : {rank : CoordinateRank} → SpaceName rank → FiniteSpace + NamedFiniteSpace : {rank : Number} → SpaceName rank → FiniteSpace public export -space_rank : FiniteSpace → CoordinateRank +space_rank : FiniteSpace → Number space_rank (NamedFiniteSpace {rank} _) = rank public export @@ -46,11 +42,11 @@ public export real128_space : FiniteSpace real128_space = NamedFiniteSpace Real128Name --- ±Number coordinates are exact executable samples of the named real +-- Integer coordinates are exact executable samples of the named real -- coordinate spaces. ExactVectorSample and ExactCovectorSample below -- represent only this sample language; they are not definitions of the -- complete real scalar field or of every vector in the ambient space. This --- preserves the R^128 oracle without pretending ±Number is the field of reals. +-- preserves the R^128 oracle without pretending Integer is the field of reals. -- UNSAFE REPRESENTATION BOUNDARY. The raw coordinates, their constructors, -- and every operation that exposes or rebuilds them are deliberately named @@ -61,20 +57,20 @@ real128_space = NamedFiniteSpace Real128Name -- never performs such a conversion implicitly. public export -data RawExactCoordinates : CoordinateRank → Type where +data RawExactCoordinates : Number → Type where UnsafeCoordinateNil : RawExactCoordinates Z UnsafeCoordinateCons : - {n : CoordinateRank} → - ±Number → RawExactCoordinates n → RawExactCoordinates (S n) + {n : Number} → + Integer → RawExactCoordinates n → RawExactCoordinates (S n) public export -unsafe_zero_coordinates : (n : CoordinateRank) → RawExactCoordinates n +unsafe_zero_coordinates : (n : Number) → RawExactCoordinates n unsafe_zero_coordinates Z = UnsafeCoordinateNil unsafe_zero_coordinates (S n) = UnsafeCoordinateCons 0 (unsafe_zero_coordinates n) public export unsafe_add_coordinates : - {n : CoordinateRank} → + {n : Number} → RawExactCoordinates n → RawExactCoordinates n → RawExactCoordinates n unsafe_add_coordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil unsafe_add_coordinates @@ -85,14 +81,14 @@ unsafe_add_coordinates (unsafe_add_coordinates left_rest right_rest) public export -unsafe_negate_coordinates : {n : CoordinateRank} → RawExactCoordinates n → RawExactCoordinates n +unsafe_negate_coordinates : {n : Number} → RawExactCoordinates n → RawExactCoordinates n unsafe_negate_coordinates UnsafeCoordinateNil = UnsafeCoordinateNil unsafe_negate_coordinates (UnsafeCoordinateCons value rest) = UnsafeCoordinateCons (-value) (unsafe_negate_coordinates rest) public export unsafe_subtract_coordinates : - {n : CoordinateRank} → + {n : Number} → RawExactCoordinates n → RawExactCoordinates n → RawExactCoordinates n unsafe_subtract_coordinates UnsafeCoordinateNil UnsafeCoordinateNil = UnsafeCoordinateNil unsafe_subtract_coordinates @@ -104,7 +100,7 @@ unsafe_subtract_coordinates public export unsafe_scale_coordinates : - {n : CoordinateRank} → ±Number → RawExactCoordinates n → RawExactCoordinates n + {n : Number} → Integer → RawExactCoordinates n → RawExactCoordinates n unsafe_scale_coordinates scalar UnsafeCoordinateNil = UnsafeCoordinateNil unsafe_scale_coordinates scalar (UnsafeCoordinateCons value rest) = UnsafeCoordinateCons @@ -116,8 +112,8 @@ unsafe_scale_coordinates scalar (UnsafeCoordinateCons value rest) = -- the checked vector/covector API; `dot` is the metric-requiring operation. public export unsafe_pair_coordinates : - {n : CoordinateRank} → - RawExactCoordinates n → RawExactCoordinates n → ±Number + {n : Number} → + RawExactCoordinates n → RawExactCoordinates n → Integer unsafe_pair_coordinates UnsafeCoordinateNil UnsafeCoordinateNil = 0 unsafe_pair_coordinates (UnsafeCoordinateCons left left_rest) @@ -130,7 +126,7 @@ unsafe_pair_coordinates public export data ExactVectorSample : FiniteSpace → Type where UnsafeVectorCoordinates : - {rank : CoordinateRank} → + {rank : Number} → {name : SpaceName rank} → RawExactCoordinates rank → ExactVectorSample (NamedFiniteSpace name) @@ -138,7 +134,7 @@ data ExactVectorSample : FiniteSpace → Type where public export data ExactCovectorSample : FiniteSpace → Type where UnsafeCovectorCoordinates : - {rank : CoordinateRank} → + {rank : Number} → {name : SpaceName rank} → RawExactCoordinates rank → ExactCovectorSample (NamedFiniteSpace name) @@ -190,7 +186,7 @@ difference_vector public export scale_vector : {space : FiniteSpace} → - ±Number → ExactVectorSample space → ExactVectorSample space + Integer → ExactVectorSample space → ExactVectorSample space scale_vector scalar (UnsafeVectorCoordinates coordinates) = UnsafeVectorCoordinates (unsafe_scale_coordinates scalar coordinates) @@ -215,7 +211,7 @@ negate_covector (UnsafeCovectorCoordinates coordinates) = public export scale_covector : {space : FiniteSpace} → - ±Number → ExactCovectorSample space → ExactCovectorSample space + Integer → ExactCovectorSample space → ExactCovectorSample space scale_covector scalar (UnsafeCovectorCoordinates coordinates) = UnsafeCovectorCoordinates (unsafe_scale_coordinates scalar coordinates) @@ -227,7 +223,7 @@ scale_covector scalar (UnsafeCovectorCoordinates coordinates) = public export contract : {space : FiniteSpace} → - ExactCovectorSample space → ExactVectorSample space → ±Number + ExactCovectorSample space → ExactVectorSample space → Integer contract (UnsafeCovectorCoordinates covector_coordinates) (UnsafeVectorCoordinates vector_coordinates) = @@ -236,31 +232,31 @@ contract -- Small named fixtures used by the focused compiler tests. public export -plane_vector : ±Number → ±Number → ExactVectorSample plane_space +plane_vector : Integer → Integer → ExactVectorSample plane_space plane_vector first second = UnsafeVectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -plane_covector : ±Number → ±Number → ExactCovectorSample plane_space +plane_covector : Integer → Integer → ExactCovectorSample plane_space plane_covector first second = UnsafeCovectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -image_plane_vector : ±Number → ±Number → ExactVectorSample image_plane_space +image_plane_vector : Integer → Integer → ExactVectorSample image_plane_space image_plane_vector first second = UnsafeVectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -image_plane_covector : ±Number → ±Number → ExactCovectorSample image_plane_space +image_plane_covector : Integer → Integer → ExactCovectorSample image_plane_space image_plane_covector first second = UnsafeCovectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second UnsafeCoordinateNil)) public export -three_vector : ±Number → ±Number → ±Number → ExactVectorSample real_three_space +three_vector : Integer → Integer → Integer → ExactVectorSample real_three_space three_vector first second third = UnsafeVectorCoordinates (UnsafeCoordinateCons first @@ -268,7 +264,7 @@ three_vector first second third = (UnsafeCoordinateCons third UnsafeCoordinateNil))) public export -three_covector : ±Number → ±Number → ±Number → ExactCovectorSample real_three_space +three_covector : Integer → Integer → Integer → ExactCovectorSample real_three_space three_covector first second third = UnsafeCovectorCoordinates (UnsafeCoordinateCons first @@ -294,6 +290,6 @@ data IndexedValue : Variance → FiniteSpace → Type where public export contract_index : {space : FiniteSpace} → - IndexedValue Lower space → IndexedValue Upper space → ±Number + IndexedValue Lower space → IndexedValue Upper space → Integer contract_index (LowerIndex covector) (UpperIndex vector) = contract covector vector diff --git a/_/examples/unified-higher-mathematics/PresheafRestriction.idric b/_/examples/unified-higher-mathematics/PresheafRestriction.idric index 3eb8f4a5fd..eaaf9741aa 100644 --- a/_/examples/unified-higher-mathematics/PresheafRestriction.idric +++ b/_/examples/unified-higher-mathematics/PresheafRestriction.idric @@ -18,9 +18,9 @@ data Included : Open → Open → Type where public export data Section : Open → Type where - WholeSection : ±Number → Section Whole - PatchSection : ±Number → Section Patch - PointSection : ±Number → Section Point + WholeSection : Integer → Section Whole + PatchSection : Integer → Section Patch + PointSection : Integer → Section Point public export restrict : {u, v : Open} → Included v u → Section u → Section v diff --git a/_/examples/unified-higher-mathematics/README.md b/_/examples/unified-higher-mathematics/README.md index 10151bb5a3..77745f92df 100644 --- a/_/examples/unified-higher-mathematics/README.md +++ b/_/examples/unified-higher-mathematics/README.md @@ -14,14 +14,14 @@ name is itself indexed by its rank, so `PlaneName` cannot be reused at rank and `image_plane_space` remain different even though both have rank two. `ExactVectorSample space` and `ExactCovectorSample space` are separate -datatypes. They are explicitly the executable signed-number-coordinate fragment of +datatypes. They are explicitly the executable integer-coordinate fragment of the named real coordinate space, not its complete carrier and not a claim that -the field of real scalars is `±Number`. Every represented sample nevertheless +the field of real scalars is `Integer`. Every represented sample nevertheless denotes a genuine vector or covector. The metric-free operation is covector evaluation: ```idris -contract : ExactCovectorSample space → ExactVectorSample space → ±Number +contract : ExactCovectorSample space → ExactVectorSample space → Integer ``` `RawExactCoordinates`, `UnsafeVectorCoordinates`, and the other diff --git a/_/examples/unified-higher-mathematics/Tests.idric b/_/examples/unified-higher-mathematics/Tests.idric index b781b60caa..9c4f011b2a 100644 --- a/_/examples/unified-higher-mathematics/Tests.idric +++ b/_/examples/unified-higher-mathematics/Tests.idric @@ -17,7 +17,7 @@ import NamedFacts -- -------------------------------------------------------------------------- plane_pairing_test : - contract (plane_covector 5 7) (plane_vector 3 4) = the ±Number 43 + contract (plane_covector 5 7) (plane_vector 3 4) = 43 plane_pairing_test = Refl contraction_linear_in_vector_test : @@ -40,37 +40,37 @@ contraction_respects_vector_scaling_test : contract (plane_covector 5 7) (scale_vector 3 (plane_vector 3 4)) - = the ±Number 3 * contract (plane_covector 5 7) (plane_vector 3 4) + = 3 * contract (plane_covector 5 7) (plane_vector 3 4) contraction_respects_vector_scaling_test = Refl contraction_respects_covector_scaling_test : contract (scale_covector 3 (plane_covector 5 7)) (plane_vector 3 4) - = the ±Number 3 * contract (plane_covector 5 7) (plane_vector 3 4) + = 3 * contract (plane_covector 5 7) (plane_vector 3 4) contraction_respects_covector_scaling_test = Refl failing "Mismatch between: PlaneName and ImagePlaneName." equal_rank_named_spaces_do_not_unify : ExactVectorSample image_plane_space equal_rank_named_spaces_do_not_unify = plane_vector 1 2 -failing "Mismatch between: 0 and S" +failing "Mismatch between: 0 and 1." one_name_cannot_claim_a_different_rank : FiniteSpace one_name_cannot_claim_a_different_rank = NamedFiniteSpace {rank = 3} PlaneName failing "Mismatch between: RealThreeName and PlaneName." - mismatched_dimension_contraction : ±Number + mismatched_dimension_contraction : Integer mismatched_dimension_contraction = contract (plane_covector 1 2) (three_vector 3 4 5) failing "Mismatch between: ImagePlaneName and PlaneName." - equal_rank_mismatched_space_contraction : ±Number + equal_rank_mismatched_space_contraction : Integer equal_rank_mismatched_space_contraction = contract (plane_covector 1 2) (image_plane_vector 3 4) failing "Mismatch between: ExactVectorSample plane_space and ExactCovectorSample" - vector_vector_contraction_without_euclidean_structure : ±Number + vector_vector_contraction_without_euclidean_structure : Integer vector_vector_contraction_without_euclidean_structure = contract (plane_vector 1 2) (plane_vector 3 4) @@ -87,11 +87,11 @@ metric_raises_covector_test : metric_raises_covector_test = Refl metric_dot_test : - dot plane_euclidean (plane_vector 3 4) (plane_vector 5 7) = the ±Number 43 + dot plane_euclidean (plane_vector 3 4) (plane_vector 5 7) = 43 metric_dot_test = Refl metric_squared_norm_test : - squared_norm plane_euclidean (plane_vector 3 4) = the ±Number 25 + squared_norm plane_euclidean (plane_vector 3 4) = 25 metric_squared_norm_test = Refl metric_norm_test : @@ -102,7 +102,7 @@ metric_squared_distance_test : squared_distance plane_euclidean (plane_vector 5 7) - (plane_vector 2 3) = the ±Number 25 + (plane_vector 2 3) = 25 metric_squared_distance_test = Refl metric_distance_test : @@ -119,18 +119,18 @@ metric_distance_test = Refl named_index_contraction_test : contract_index (LowerIndex (plane_covector 5 7)) - (UpperIndex (plane_vector 3 4)) = the ±Number 43 + (UpperIndex (plane_vector 3 4)) = 43 named_index_contraction_test = Refl failing "Mismatch between: Lower and Upper." - same_variance_index_contraction : ±Number + same_variance_index_contraction : Integer same_variance_index_contraction = contract_index (LowerIndex (plane_covector 5 7)) (LowerIndex (plane_covector 3 4)) failing "Mismatch between: ImagePlaneName and PlaneName." - equal_rank_named_index_space_mismatch : ±Number + equal_rank_named_index_space_mismatch : Integer equal_rank_named_index_space_mismatch = contract_index (LowerIndex (plane_covector 5 7)) @@ -139,7 +139,7 @@ failing "Mismatch between: ImagePlaneName and PlaneName." metric_driven_index_lowering_test : contract_index (lower_indexed plane_euclidean (UpperIndex (plane_vector 5 7))) - (UpperIndex (plane_vector 3 4)) = the ±Number 43 + (UpperIndex (plane_vector 3 4)) = 43 metric_driven_index_lowering_test = Refl metric_driven_index_raising_test : @@ -160,7 +160,7 @@ metric_driven_index_raising_test = Refl -- state all 128 coordinates; semantic clients use the named constructors and -- checked contraction/metric operations above. -last_coordinate : (n : CoordinateRank) → ±Number → RawExactCoordinates (S n) +last_coordinate : (n : Number) → Integer → RawExactCoordinates (S n) last_coordinate Z value = UnsafeCoordinateCons value UnsafeCoordinateNil last_coordinate (S n) value = UnsafeCoordinateCons 0 (last_coordinate n value) @@ -233,27 +233,27 @@ r128_quarter_turn_exact_image_test = Refl r128_reflection_preserves_squared_norm_test : squared_norm real128_euclidean - (apply_first_axis_reflection real128_euclidean r128_sample) = the ±Number 250 + (apply_first_axis_reflection real128_euclidean r128_sample) = 250 r128_reflection_preserves_squared_norm_test = Refl r128_quarter_turn_preserves_squared_norm_test : squared_norm real128_euclidean - (apply_first_plane_quarter_turn real128_euclidean r128_sample) = the ±Number 250 + (apply_first_plane_quarter_turn real128_euclidean r128_sample) = 250 r128_quarter_turn_preserves_squared_norm_test = Refl r128_reflection_preserves_dot_test : dot real128_euclidean (apply_first_axis_reflection real128_euclidean r128_sample) - (apply_first_axis_reflection real128_euclidean r128_companion) = the ±Number 190 + (apply_first_axis_reflection real128_euclidean r128_companion) = 190 r128_reflection_preserves_dot_test = Refl r128_quarter_turn_preserves_dot_test : dot real128_euclidean (apply_first_plane_quarter_turn real128_euclidean r128_sample) - (apply_first_plane_quarter_turn real128_euclidean r128_companion) = the ±Number 190 + (apply_first_plane_quarter_turn real128_euclidean r128_companion) = 190 r128_quarter_turn_preserves_dot_test = Refl r128_reflection_is_involution_test : @@ -270,7 +270,7 @@ r128_four_quarter_turns_are_identity_test : = r128_sample r128_four_quarter_turns_are_identity_test = Refl -last_coordinate_value : {n : CoordinateRank} → RawExactCoordinates (S n) → ±Number +last_coordinate_value : {n : Number} → RawExactCoordinates (S n) → Integer last_coordinate_value (UnsafeCoordinateCons value UnsafeCoordinateNil) = value last_coordinate_value (UnsafeCoordinateCons _ rest@(UnsafeCoordinateCons _ _)) = last_coordinate_value rest @@ -278,13 +278,13 @@ last_coordinate_value r128_reflection_preserves_coordinate_128_test : last_coordinate_value (unsafe_coordinates_of_vector - (apply_first_axis_reflection real128_euclidean r128_sample)) = the ±Number 9 + (apply_first_axis_reflection real128_euclidean r128_sample)) = 9 r128_reflection_preserves_coordinate_128_test = Refl r128_quarter_turn_preserves_coordinate_128_test : last_coordinate_value (unsafe_coordinates_of_vector - (apply_first_plane_quarter_turn real128_euclidean r128_sample)) = the ±Number 9 + (apply_first_plane_quarter_turn real128_euclidean r128_sample)) = 9 r128_quarter_turn_preserves_coordinate_128_test = Refl -- -------------------------------------------------------------------------- @@ -294,22 +294,22 @@ r128_quarter_turn_preserves_coordinate_128_test = Refl north_pole_is_s2_test : UnitSpherePoint real_three_euclidean north_pole_is_s2_test = north_pole_s2 -sphere_s0_h0_rank_test : sphere_integral_cohomology_rank 0 0 = the Cardinality 2 +sphere_s0_h0_rank_test : sphere_integral_cohomology_rank 0 0 = 2 sphere_s0_h0_rank_test = Refl -sphere_s2_h0_rank_test : sphere_integral_cohomology_rank 2 0 = the Cardinality 1 +sphere_s2_h0_rank_test : sphere_integral_cohomology_rank 2 0 = 1 sphere_s2_h0_rank_test = Refl -sphere_s2_h1_rank_test : sphere_integral_cohomology_rank 2 1 = the Cardinality 0 +sphere_s2_h1_rank_test : sphere_integral_cohomology_rank 2 1 = 0 sphere_s2_h1_rank_test = Refl -sphere_s2_h2_rank_test : sphere_integral_cohomology_rank 2 2 = the Cardinality 1 +sphere_s2_h2_rank_test : sphere_integral_cohomology_rank 2 2 = 1 sphere_s2_h2_rank_test = Refl -odd_sphere_euler_test : sphere_euler_characteristic 3 = the ±Number 0 +odd_sphere_euler_test : sphere_euler_characteristic 3 = 0 odd_sphere_euler_test = Refl -even_sphere_euler_test : sphere_euler_characteristic 4 = the ±Number 2 +even_sphere_euler_test : sphere_euler_characteristic 4 = 2 even_sphere_euler_test = Refl quaternion_i_j_test : quaternion_multiply quaternion_i quaternion_j = quaternion_k @@ -319,7 +319,7 @@ quaternion_j_i_test : quaternion_multiply quaternion_j quaternion_i = quaternion_negate quaternion_k quaternion_j_i_test = Refl -quaternion_i_norm_test : quaternion_norm_squared quaternion_i = the ±Number 1 +quaternion_i_norm_test : quaternion_norm_squared quaternion_i = 1 quaternion_i_norm_test = Refl unit_quaternion_rotation_is_so3_test : SpecialOrthogonal real_three_euclidean @@ -331,30 +331,29 @@ unit_quaternion_rotation_action_test : (three_vector 0 1 0) = three_vector 0 (-1) 0 unit_quaternion_rotation_action_test = Refl -cp3_real_dimension_test : cp_real_dimension 3 = the Cardinality 6 +cp3_real_dimension_test : cp_real_dimension 3 = 6 cp3_real_dimension_test = Refl -cp3_hopf_sphere_dimension_test : cp_hopf_sphere_dimension 3 = the Cardinality 7 +cp3_hopf_sphere_dimension_test : cp_hopf_sphere_dimension 3 = 7 cp3_hopf_sphere_dimension_test = Refl -cp2_h0_rank_test : cp_integral_cohomology_rank 2 0 = the Cardinality 1 +cp2_h0_rank_test : cp_integral_cohomology_rank 2 0 = 1 cp2_h0_rank_test = Refl -cp2_h2_rank_test : cp_integral_cohomology_rank 2 2 = the Cardinality 1 +cp2_h2_rank_test : cp_integral_cohomology_rank 2 2 = 1 cp2_h2_rank_test = Refl -cp2_h4_rank_test : cp_integral_cohomology_rank 2 4 = the Cardinality 1 +cp2_h4_rank_test : cp_integral_cohomology_rank 2 4 = 1 cp2_h4_rank_test = Refl -cp2_h3_rank_test : cp_integral_cohomology_rank 2 3 = the Cardinality 0 +cp2_h3_rank_test : cp_integral_cohomology_rank 2 3 = 0 cp2_h3_rank_test = Refl -cp2_h6_rank_test : cp_integral_cohomology_rank 2 6 = the Cardinality 0 +cp2_h6_rank_test : cp_integral_cohomology_rank 2 6 = 0 cp2_h6_rank_test = Refl r3_one_point_compactifies_to_s3_test : - compactified_sphere_dimension (euclidean_one_point_compactification 3) = - the Cardinality 3 + compactified_sphere_dimension (euclidean_one_point_compactification 3) = 3 r3_one_point_compactifies_to_s3_test = Refl -- -------------------------------------------------------------------------- @@ -403,7 +402,7 @@ failing "Mismatch between: ExactVectorSample plane_space and EmbeddedCircleInS2. lookup_named_fact jordan_separation_fact unrelated_context jordan_lookup_conclusion_test : - complement_component_count (fact_conclusion jordan_lookup_test) = the Number 2 + complement_component_count (fact_conclusion jordan_lookup_test) = 2 jordan_lookup_conclusion_test = Refl jordan_lookup_explanation_test : diff --git a/_/examples/unified-higher-mathematics/TopologyFacts.idric b/_/examples/unified-higher-mathematics/TopologyFacts.idric index ef722ba880..c7d4d0e1d6 100644 --- a/_/examples/unified-higher-mathematics/TopologyFacts.idric +++ b/_/examples/unified-higher-mathematics/TopologyFacts.idric @@ -11,26 +11,6 @@ import EuclideanGeometry -- boundaries. Nothing here computes general cohomology, constructs arbitrary -- quotients, or proves a separation theorem from coordinates. -public export -Dimension : Type -Dimension = Cardinality - -public export -CohomologicalDegree : Type -CohomologicalDegree = Cardinality - -public export -CohomologyRank : Type -CohomologyRank = Cardinality - -public export -EulerCharacteristic : Type -EulerCharacteristic = ±Number - -public export -ConnectedComponentCount : Type -ConnectedComponentCount = Number - -- -------------------------------------------------------------------------- -- Spheres in explicitly Euclidean ambient spaces -- -------------------------------------------------------------------------- @@ -48,7 +28,7 @@ data UnitSpherePoint : {space : FiniteSpace} → {structure : EuclideanStructure space} → (coordinates : ExactVectorSample space) → - squared_norm structure coordinates = the ±Number 1 → + squared_norm structure coordinates = 1 → UnitSpherePoint structure -- S^2 is represented in the named Euclidean R^3 fixture. The norm-one @@ -63,7 +43,7 @@ north_pole_s2 = -- only nonzero ranks are in degrees 0 and n. This is a closed standard fact, -- not a general cohomology calculation. public export -sphere_integral_cohomology_rank : Dimension → CohomologicalDegree → CohomologyRank +sphere_integral_cohomology_rank : Number → Number → Number sphere_integral_cohomology_rank Z Z = 2 sphere_integral_cohomology_rank Z (S degree) = 0 sphere_integral_cohomology_rank (S dimension) Z = 1 @@ -79,15 +59,15 @@ flip_parity Even = Odd flip_parity Odd = Even public export -dimension_parity : Dimension → Parity -dimension_parity Z = Even -dimension_parity (S n) = flip_parity (dimension_parity n) +number_parity : Number → Parity +number_parity Z = Even +number_parity (S n) = flip_parity (number_parity n) -- chi(S^n) = 1 + (-1)^n. public export -sphere_euler_characteristic : Dimension → EulerCharacteristic +sphere_euler_characteristic : Number → Integer sphere_euler_characteristic dimension = - case dimension_parity dimension of + case number_parity dimension of Even ⇒ 2 Odd ⇒ 0 @@ -97,21 +77,21 @@ sphere_euler_characteristic dimension = -- CP^n has complex dimension n and real dimension 2n. public export -cp_real_dimension : Dimension → Dimension +cp_real_dimension : Number → Number cp_real_dimension n = n + n -- CP^n has the standard Hopf presentation S^(2n+1) / S^1. This returns the -- dimension of the sphere in that presentation; it does not implement quotient -- equality or construct projective space. public export -cp_hopf_sphere_dimension : Dimension → Dimension +cp_hopf_sphere_dimension : Number → Number cp_hopf_sphere_dimension n = S (n + n) -- Additive integral cohomology ranks of CP^n are one in even degrees -- 0,2,...,2n and zero otherwise. The ring structure is deliberately outside -- this small fact table. public export -cp_integral_cohomology_rank : Dimension → CohomologicalDegree → CohomologyRank +cp_integral_cohomology_rank : Number → Number → Number cp_integral_cohomology_rank n Z = 1 cp_integral_cohomology_rank Z (S degree) = 0 cp_integral_cohomology_rank (S n) (S Z) = 0 @@ -119,11 +99,11 @@ cp_integral_cohomology_rank (S n) (S (S degree)) = cp_integral_cohomology_rank n degree public export -data HopfQuotientFact : Dimension → Type where - CPnAsSphereByCircle : (n : Dimension) → HopfQuotientFact n +data HopfQuotientFact : Number → Type where + CPnAsSphereByCircle : (n : Number) → HopfQuotientFact n public export -cp_hopf_quotient : (n : Dimension) → HopfQuotientFact n +cp_hopf_quotient : (n : Number) → HopfQuotientFact n cp_hopf_quotient n = CPnAsSphereByCircle n -- -------------------------------------------------------------------------- @@ -154,24 +134,24 @@ jordan_separation curve = ExactlyTwoComplementComponents curve public export complement_component_count : - {curve : EmbeddedCircleInS2} → JordanSeparation curve → ConnectedComponentCount + {curve : EmbeddedCircleInS2} → JordanSeparation curve → Number complement_component_count (ExactlyTwoComplementComponents curve) = 2 -- The one-point compactification of Euclidean R^n is S^n. The family is -- indexed explicitly so this fact cannot be mistaken for a generic -- compactification operation on arbitrary spaces. public export -data EuclideanCompactificationFact : Dimension → Type where +data EuclideanCompactificationFact : Number → Type where EuclideanPlusIsSphere : - (dimension : Dimension) → EuclideanCompactificationFact dimension + (dimension : Number) → EuclideanCompactificationFact dimension public export euclidean_one_point_compactification : - (dimension : Dimension) → EuclideanCompactificationFact dimension + (dimension : Number) → EuclideanCompactificationFact dimension euclidean_one_point_compactification dimension = EuclideanPlusIsSphere dimension public export compactified_sphere_dimension : - {n : Dimension} → EuclideanCompactificationFact n → Dimension + {n : Number} → EuclideanCompactificationFact n → Number compactified_sphere_dimension (EuclideanPlusIsSphere dimension) = dimension diff --git a/_/koans/01-values-types-and-holes/exercise/Main.idric b/_/koans/01-values-types-and-holes/exercise/Main.idric index a0998bff7e..23264768e8 100644 --- a/_/koans/01-values-types-and-holes/exercise/Main.idric +++ b/_/koans/01-values-types-and-holes/exercise/Main.idric @@ -2,7 +2,7 @@ module Main -- Compile this file and read the types reported for these named holes. answer : Number -answer = ?number_value +answer = ?natural_number message : Text message = ?text_value diff --git a/_/koans/01-values-types-and-holes/expected-diagnostic b/_/koans/01-values-types-and-holes/expected-diagnostic index bf4934857f..e35b171330 100644 --- a/_/koans/01-values-types-and-holes/expected-diagnostic +++ b/_/koans/01-values-types-and-holes/expected-diagnostic @@ -1,2 +1,2 @@ -number_value +natural_number text_value diff --git a/_/koans/01-values-types-and-holes/holes b/_/koans/01-values-types-and-holes/holes index bf4934857f..e35b171330 100644 --- a/_/koans/01-values-types-and-holes/holes +++ b/_/koans/01-values-types-and-holes/holes @@ -1,2 +1,2 @@ -number_value +natural_number text_value diff --git a/_/koans/02-functions-with-unicode-arrows/solution/Main.idric b/_/koans/02-functions-with-unicode-arrows/solution/Main.idric index 99a0c0f1f0..4333db3c03 100644 --- a/_/koans/02-functions-with-unicode-arrows/solution/Main.idric +++ b/_/koans/02-functions-with-unicode-arrows/solution/Main.idric @@ -1,7 +1,7 @@ module Main increment : Number → Number -increment = \number ⇒ number + 1 +increment = \number ⇒ S number twice : (a → a) → a → a twice = \function ⇒ \value ⇒ function (function value) diff --git a/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric b/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric index e40eaab067..5bfd478ee3 100644 --- a/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric @@ -15,4 +15,4 @@ prepend value values = ?longer_list main : IO () main = do printLn (List.length numbers) - printLn (prepend 1 exactly_three) + printLn (prepend 0 exactly_three) diff --git a/_/koans/03-lists-and-length-indexed-lists/expected b/_/koans/03-lists-and-length-indexed-lists/expected index 25b93ad9d1..3487407098 100644 --- a/_/koans/03-lists-and-length-indexed-lists/expected +++ b/_/koans/03-lists-and-length-indexed-lists/expected @@ -1,2 +1,2 @@ 3 -[1, 2, 4, 6] +[0, 2, 4, 6] diff --git a/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric b/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric index cb2b43008c..85b98d3248 100644 --- a/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric @@ -15,4 +15,4 @@ prepend value values = value :: values main : IO () main = do printLn (List.length numbers) - printLn (prepend 1 exactly_three) + printLn (prepend 0 exactly_three) diff --git a/_/koans/06-implicit-dependent-results/exercise/Main.idric b/_/koans/06-implicit-dependent-results/exercise/Main.idric index 9b9d3abbb7..baf33de2e5 100644 --- a/_/koans/06-implicit-dependent-results/exercise/Main.idric +++ b/_/koans/06-implicit-dependent-results/exercise/Main.idric @@ -2,8 +2,8 @@ module Main import Data.Vect --- The zero-capable cardinality is inferred from the compatibility Vect value. -prepend : {n : Cardinality} → a → Vect n a → Vect (S n) a +-- n is inferred from values; the result type depends on that inferred value. +prepend : {n : Number} → a → Vect n a → Vect (S n) a prepend item items = ?dependent_result main : IO () diff --git a/_/koans/06-implicit-dependent-results/solution/Main.idric b/_/koans/06-implicit-dependent-results/solution/Main.idric index 8dd86edf06..a2cd47b03d 100644 --- a/_/koans/06-implicit-dependent-results/solution/Main.idric +++ b/_/koans/06-implicit-dependent-results/solution/Main.idric @@ -2,7 +2,7 @@ module Main import Data.Vect -prepend : {n : Cardinality} → a → Vect n a → Vect (S n) a +prepend : {n : Number} → a → Vect n a → Vect (S n) a prepend item items = item :: items main : IO () diff --git a/_/koans/07-erased-arguments/expected-diagnostic b/_/koans/07-erased-arguments/expected-diagnostic index 63a14f190e..70493c34dc 100644 --- a/_/koans/07-erased-arguments/expected-diagnostic +++ b/_/koans/07-erased-arguments/expected-diagnostic @@ -1,2 +1,2 @@ runtime_number_only -0 compile_time_number : Number +0 compile_time_number : Nat diff --git a/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric b/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric index e2c9bd9e61..24bff826f4 100644 --- a/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric +++ b/_/koans/10-exhaustive-choice-patterns/exercise/Main.idric @@ -1,7 +1,7 @@ module Main choice touch_beginning one_of - near_existing Cardinality + near_existing Number empty_domain describe : touch_beginning → Text diff --git a/_/koans/10-exhaustive-choice-patterns/solution/Main.idric b/_/koans/10-exhaustive-choice-patterns/solution/Main.idric index ea4e6af4be..1292af67c3 100644 --- a/_/koans/10-exhaustive-choice-patterns/solution/Main.idric +++ b/_/koans/10-exhaustive-choice-patterns/solution/Main.idric @@ -1,7 +1,7 @@ module Main choice touch_beginning one_of - near_existing Cardinality + near_existing Number empty_domain describe : touch_beginning → Text diff --git a/_/koans/11-source-boundaries/exercise/IdrisCompatibility.idr b/_/koans/11-source-boundaries/exercise/IdrisCompatibility.idr index b88beb3be3..e661a0edbb 100644 --- a/_/koans/11-source-boundaries/exercise/IdrisCompatibility.idr +++ b/_/koans/11-source-boundaries/exercise/IdrisCompatibility.idr @@ -12,5 +12,5 @@ joined→⇒←≤name : Nat joined→⇒←≤name = 40 export -compatibility_value : Number -compatibility_value = OneMore (choice joined→⇒←≤name) +compatibility_value : Nat +compatibility_value = choice (one_of joined→⇒←≤name) diff --git a/_/koans/11-source-boundaries/exercise/Main.idric b/_/koans/11-source-boundaries/exercise/Main.idric index 977d64d95f..e10dc9702e 100644 --- a/_/koans/11-source-boundaries/exercise/Main.idric +++ b/_/koans/11-source-boundaries/exercise/Main.idric @@ -3,7 +3,7 @@ module Main import IdrisCompatibility increment : Number → Number -increment = \value ⇒ value + 1 +increment = \value ⇒ S value boundary_value : Number boundary_value = ?value_from_both_languages diff --git a/_/koans/11-source-boundaries/solution/IdrisCompatibility.idr b/_/koans/11-source-boundaries/solution/IdrisCompatibility.idr index b88beb3be3..e661a0edbb 100644 --- a/_/koans/11-source-boundaries/solution/IdrisCompatibility.idr +++ b/_/koans/11-source-boundaries/solution/IdrisCompatibility.idr @@ -12,5 +12,5 @@ joined→⇒←≤name : Nat joined→⇒←≤name = 40 export -compatibility_value : Number -compatibility_value = OneMore (choice joined→⇒←≤name) +compatibility_value : Nat +compatibility_value = choice (one_of joined→⇒←≤name) diff --git a/_/koans/11-source-boundaries/solution/Main.idric b/_/koans/11-source-boundaries/solution/Main.idric index d2812a3c9c..43d92ab305 100644 --- a/_/koans/11-source-boundaries/solution/Main.idric +++ b/_/koans/11-source-boundaries/solution/Main.idric @@ -3,7 +3,7 @@ module Main import IdrisCompatibility increment : Number → Number -increment = \value ⇒ value + 1 +increment = \value ⇒ S value boundary_value : Number boundary_value = increment compatibility_value diff --git a/_/koans/12-wegert-model/exercise/Main.idric b/_/koans/12-wegert-model/exercise/Main.idric index 36edaf3460..f8eaa88e1c 100644 --- a/_/koans/12-wegert-model/exercise/Main.idric +++ b/_/koans/12-wegert-model/exercise/Main.idric @@ -7,16 +7,16 @@ choice placement_kind one_of new_pole choice placed_point one_of - zero_at ±Number - pole_at ±Number + zero_at Number + pole_at Number -make_point : placement_kind → ±Number → placed_point +make_point : placement_kind → Number → placed_point make_point new_zero coordinate = ?zero_point make_point new_pole coordinate = ?pole_point place : (kind : placement_kind) → - (coordinate : ±Number) → + (coordinate : Number) → (points : Vect n placed_point) → (updated : Vect (S n) placed_point ** Vect.head updated = make_point kind coordinate) @@ -26,7 +26,7 @@ describe_point : placed_point → Text describe_point (zero_at coordinate) = "zero at " ++ show coordinate describe_point (pole_at coordinate) = "pole at " ++ show coordinate -first_description : placement_kind → ±Number → Vect n placed_point → Text +first_description : placement_kind → Number → Vect n placed_point → Text first_description kind coordinate points = let (updated ** first_is_new) = place kind coordinate points in describe_point (Vect.head updated) diff --git a/_/koans/12-wegert-model/solution/Main.idric b/_/koans/12-wegert-model/solution/Main.idric index 3a4c0620d4..848f155397 100644 --- a/_/koans/12-wegert-model/solution/Main.idric +++ b/_/koans/12-wegert-model/solution/Main.idric @@ -7,16 +7,16 @@ choice placement_kind one_of new_pole choice placed_point one_of - zero_at ±Number - pole_at ±Number + zero_at Number + pole_at Number -make_point : placement_kind → ±Number → placed_point +make_point : placement_kind → Number → placed_point make_point new_zero coordinate = zero_at coordinate make_point new_pole coordinate = pole_at coordinate place : (kind : placement_kind) → - (coordinate : ±Number) → + (coordinate : Number) → (points : Vect n placed_point) → (updated : Vect (S n) placed_point ** Vect.head updated = make_point kind coordinate) @@ -27,7 +27,7 @@ describe_point : placed_point → Text describe_point (zero_at coordinate) = "zero at " ++ show coordinate describe_point (pole_at coordinate) = "pole at " ++ show coordinate -first_description : placement_kind → ±Number → Vect n placed_point → Text +first_description : placement_kind → Number → Vect n placed_point → Text first_description kind coordinate points = let (updated ** first_is_new) = place kind coordinate points in describe_point (Vect.head updated) diff --git a/_/libs/prelude/Prelude/Cast.idr b/_/libs/prelude/Prelude/Cast.idr index a9e803a3bf..d362485ed9 100644 --- a/_/libs/prelude/Prelude/Cast.idr +++ b/_/libs/prelude/Prelude/Cast.idr @@ -100,20 +100,6 @@ export %inline Cast Nat Integer where cast = natToInteger -||| Widening a positive Idriç `Number` to `±Number` is lossless. -export %inline -Cast Number ±Number where - cast = numberAsSigned - -||| Explicit bootstrap representation boundaries for the signed source type. -export %inline -Cast ±Number Integer where - cast = signedAsInteger - -export %inline -Cast Integer ±Number where - cast = SignedValue - export %inline Cast Bits8 Integer where cast = prim__cast_Bits8Integer diff --git a/_/libs/prelude/Prelude/Num.idr b/_/libs/prelude/Prelude/Num.idr index c7ea2e8bff..8a2763b5be 100644 --- a/_/libs/prelude/Prelude/Num.idr +++ b/_/libs/prelude/Prelude/Num.idr @@ -22,29 +22,6 @@ interface Num ty where %allow_overloads fromInteger -||| Source-facing Idriç addition. Most ordinary numeric representations obtain -||| this operation from `Num`; types with stricter invariants can provide a -||| result-preserving implementation without inventing a literal conversion. -public export -interface IdricAddition ty where - constructor MkIdricAddition - (+~+) : ty -> ty -> ty - -public export %hint -idricAdditionFromNum : Num ty => IdricAddition ty -idricAdditionFromNum = MkIdricAddition (+) - -||| Source-facing Idriç multiplication, separated from literal construction -||| for the same reason as `IdricAddition`. -public export -interface IdricMultiplication ty where - constructor MkIdricMultiplication - (*~*) : ty -> ty -> ty - -public export %hint -idricMultiplicationFromNum : Num ty => IdricMultiplication ty -idricMultiplicationFromNum = MkIdricMultiplication (*) - ||| The `Neg` interface defines operations on numbers which can be negative. public export interface Num ty => Neg ty where @@ -53,21 +30,6 @@ interface Num ty => Neg ty where negate : ty -> ty (-) : ty -> ty -> ty -||| Source-facing Idriç subtraction permits the result type to be wider than -||| its operands. In particular, `Number - Number` produces `±Number`. -public export -interface IdricSubtraction operand result | operand where - constructor MkIdricSubtraction - (-~-) : operand -> operand -> result - -public export %hint -idricSubtractionFromNeg : Neg ty => IdricSubtraction ty ty -idricSubtractionFromNeg = MkIdricSubtraction (-) - -public export -idricNegate : Neg ty => ty -> ty -idricNegate = negate - ||| A convenience alias for `(-)`, this function enables partial application of subtraction on the ||| right-hand operand as ||| ```idris example diff --git a/_/libs/prelude/Prelude/Ops.idr b/_/libs/prelude/Prelude/Ops.idr index 9018f3cd61..ed5d59bb50 100644 --- a/_/libs/prelude/Prelude/Ops.idr +++ b/_/libs/prelude/Prelude/Ops.idr @@ -4,8 +4,6 @@ module Prelude.Ops export infix 6 ==, /=, <, <=, >, >= export infixl 8 +, - export infixl 9 *, / -export infixl 8 +~+, -~- -export infixl 9 *~* -- Boolean operators export infixr 5 && diff --git a/_/libs/prelude/Prelude/Show.idr b/_/libs/prelude/Prelude/Show.idr index 2a36e97c7d..d0217c4076 100644 --- a/_/libs/prelude/Prelude/Show.idr +++ b/_/libs/prelude/Prelude/Show.idr @@ -193,14 +193,6 @@ export Show Nat where show n = show (the Integer (natToInteger n)) -export -Show Number where - show n = show (signedAsInteger (numberAsSigned n)) - -export -Show ±Number where - show n = show (signedAsInteger n) - export Show Bool where show True = "True" diff --git a/_/libs/prelude/Prelude/Types.idr b/_/libs/prelude/Prelude/Types.idr index 9b46466e99..fd1eca0fe8 100644 --- a/_/libs/prelude/Prelude/Types.idr +++ b/_/libs/prelude/Prelude/Types.idr @@ -102,110 +102,6 @@ natToInteger (S k) = 1 + natToInteger k -- %builtin NaturalToInteger Prelude.Types.natToInteger -------------------- --- IDRIC NUMBERS -- -------------------- - -||| The ordinary positive whole numbers: 1, 2, 3, and so on. -||| -||| `Number` deliberately has no zero constructor. The stored `Nat` is the -||| predecessor used by the bootstrap representation, not the Idriç meaning. -public export -data Number = OneMore Nat - -%name Number number, left_number, right_number - -||| A cardinality that may be empty. This semantic name keeps zero-capable -||| lengths and counts from being mislabeled as positive `Number` values. -public export -Cardinality : Type -Cardinality = Nat - -||| The ordinary signed whole numbers, including zero. -||| -||| The stored `Integer` is the bootstrap representation. Idriç programs use -||| this distinct type so representation names do not leak into diagnostics or -||| overload selection. -public export -data ±Number = SignedValue Integer - -%name ±Number signed_number, left_signed_number, right_signed_number - -||| Construct a `Number` literal only when the literal is strictly positive. -||| The proof is resolved during elaboration for a concrete source literal. -public export -positiveNumberFromInteger : (value : Integer) -> - {auto 0 positive : value > 0 = True} -> - Number -positiveNumberFromInteger value = OneMore $ - integerToNat (prim__sub_Integer value 1) - -||| Construct a zero-capable cardinality from a nonnegative source literal. -||| `Cardinality` is a domain name for counts and sizes, not a signed number. -public export -cardinalityFromInteger : (value : Integer) -> - {auto 0 nonnegative : value >= 0 = True} -> - Cardinality -cardinalityFromInteger value = integerToNat value - -||| Widen a positive `Number` to the signed number type. -public export -numberAsSigned : Number -> ±Number -numberAsSigned (OneMore predecessor) = - SignedValue (prim__add_Integer 1 (natToInteger predecessor)) - -||| Cross the bootstrap representation boundary explicitly. -public export -signedAsInteger : ±Number -> Integer -signedAsInteger (SignedValue value) = value - -public export -IdricAddition Number where - (+~+) (OneMore left) (OneMore right) = OneMore (S (plus left right)) - -public export -IdricMultiplication Number where - (*~*) (OneMore left) (OneMore right) = - OneMore (plus left (plus right (mult left right))) - -||| Subtracting positive numbers may produce a negative value or zero. -public export -IdricSubtraction Number ±Number where - (-~-) left right = SignedValue $ - prim__sub_Integer - (signedAsInteger (numberAsSigned left)) - (signedAsInteger (numberAsSigned right)) - -public export -Eq Number where - OneMore left == OneMore right = left == right - -public export -Ord Number where - compare (OneMore left) (OneMore right) = compare left right - -public export -Eq ±Number where - SignedValue left == SignedValue right = left == right - -public export -Ord ±Number where - compare (SignedValue left) (SignedValue right) = compare left right - -public export -Num ±Number where - SignedValue left + SignedValue right = - SignedValue (prim__add_Integer left right) - SignedValue left * SignedValue right = - SignedValue (prim__mul_Integer left right) - fromInteger = SignedValue - -public export -Neg ±Number where - negate (SignedValue value) = SignedValue (prim__sub_Integer 0 value) - SignedValue left - SignedValue right = - SignedValue (prim__sub_Integer left right) - ||| Counts the number of elements that satisfy a predicate. public export count : Foldable t => (predicate : a -> Bool) -> t a -> Nat diff --git a/_/tests/idris2/basic/edric003/Main.idric b/_/tests/idris2/basic/edric003/Main.idric index b33eaa916c..fbca646de8 100644 --- a/_/tests/idris2/basic/edric003/Main.idric +++ b/_/tests/idris2/basic/edric003/Main.idric @@ -16,10 +16,10 @@ describe_placement : placement_kind → Text describe_placement new_zero = "new_zero" describe_placement new_pole = "new_pole" -chain_depth : recursive_chain → Cardinality +chain_depth : recursive_chain → Number chain_depth chain_end = Z chain_depth (chain_link chain_end) = 1 -chain_depth (chain_link (chain_link rest)) = chain_depth rest + 2 +chain_depth (chain_link (chain_link rest)) = 2 + chain_depth rest identity : a → a identity value = value diff --git a/_/tests/idris2/basic/edric003/WegertTouch.idric b/_/tests/idris2/basic/edric003/WegertTouch.idric index 8252c0e83f..cddf741c65 100644 --- a/_/tests/idris2/basic/edric003/WegertTouch.idric +++ b/_/tests/idris2/basic/edric003/WegertTouch.idric @@ -1,14 +1,10 @@ module WegertTouch -public export -TouchCoordinate : Type -TouchCoordinate = ±Number - public export choice existing_touch_target one_of - fixed_value TouchCoordinate - zero TouchCoordinate - pole TouchCoordinate + fixed_value Number + zero Number + pole Number public export choice touch_beginning one_of diff --git a/_/tests/idris2/basic/edric005/Main.idric b/_/tests/idris2/basic/edric005/Main.idric index f45dcba17d..d7a9f77cce 100644 --- a/_/tests/idris2/basic/edric005/Main.idric +++ b/_/tests/idris2/basic/edric005/Main.idric @@ -3,13 +3,13 @@ module Main import Data.Text import IdrisCompat -unicode_function : ±Number→±Number +unicode_function : Integer→Integer unicode_function = \value⇒value + 1 -unicode_apply : (±Number→±Number)→±Number→±Number +unicode_apply : (Integer→Integer)→Integer→Integer unicode_apply = \function⇒\value⇒function value -ascii_function : ±Number -> ±Number +ascii_function : Integer -> Integer ascii_function = \value => value + 1 unicode_order : Bool diff --git a/_/tests/idris2/basic/edric010/IdrisCompatibility.idr b/_/tests/idris2/basic/edric010/IdrisCompatibility.idr deleted file mode 100644 index 335b70d091..0000000000 --- a/_/tests/idris2/basic/edric010/IdrisCompatibility.idr +++ /dev/null @@ -1,10 +0,0 @@ -module IdrisCompatibility - -ordinary_nat : Nat -ordinary_nat = 0 - -ordinary_integer : Integer -ordinary_integer = -1 - -ordinary_sum : Integer -ordinary_sum = 1 + 2 diff --git a/_/tests/idris2/basic/edric010/NegativeIsNotNumber.idric b/_/tests/idris2/basic/edric010/NegativeIsNotNumber.idric deleted file mode 100644 index a878242bf8..0000000000 --- a/_/tests/idris2/basic/edric010/NegativeIsNotNumber.idric +++ /dev/null @@ -1,4 +0,0 @@ -module NegativeIsNotNumber - -invalid_negative : Number -invalid_negative = -1 diff --git a/_/tests/idris2/basic/edric010/Valid.idric b/_/tests/idris2/basic/edric010/Valid.idric deleted file mode 100644 index 0d98e254d4..0000000000 --- a/_/tests/idris2/basic/edric010/Valid.idric +++ /dev/null @@ -1,34 +0,0 @@ -module Valid - -one : Number -one = 1 - -two : Number -two = 2 - -minus_one : ±Number -minus_one = -1 - -unicode_minus_one : ±Number -unicode_minus_one = −1 - -zero : ±Number -zero = 0 - -positive_signed : ±Number -positive_signed = 1 - -difference : ±Number -difference = one - two - -positive_sum : Number -positive_sum = one + two - -positive_product : Number -positive_product = one * two - -accept_signed : ±Number -> ±Number -accept_signed value = value - -widened : ±Number -widened = accept_signed (numberAsSigned one) diff --git a/_/tests/idris2/basic/edric010/ZeroIsNotNumber.idric b/_/tests/idris2/basic/edric010/ZeroIsNotNumber.idric deleted file mode 100644 index 95b1944b1b..0000000000 --- a/_/tests/idris2/basic/edric010/ZeroIsNotNumber.idric +++ /dev/null @@ -1,4 +0,0 @@ -module ZeroIsNotNumber - -invalid_zero : Number -invalid_zero = 0 diff --git a/_/tests/idris2/basic/edric010/expected b/_/tests/idris2/basic/edric010/expected deleted file mode 100644 index 6256974e29..0000000000 --- a/_/tests/idris2/basic/edric010/expected +++ /dev/null @@ -1,4 +0,0 @@ -Number and ±Number accepted values and arithmetic: PASS -zero rejected as Number: PASS -negative value rejected as Number: PASS -ordinary .idr numeric inference preserved: PASS diff --git a/_/tests/idris2/basic/edric010/run b/_/tests/idris2/basic/edric010/run deleted file mode 100755 index 043f54d360..0000000000 --- a/_/tests/idris2/basic/edric010/run +++ /dev/null @@ -1,28 +0,0 @@ -#!/bin/sh -set -eu - -. ../../../testutils.sh - -if ! "$idris2" --check Valid.idric >valid.log 2>&1; then - cat valid.log >&2 - exit 1 -fi -printf '%s\n' 'Number and ±Number accepted values and arithmetic: PASS' - -if "$idris2" --check ZeroIsNotNumber.idric >zero.log 2>&1; then - printf '%s\n' '0 unexpectedly elaborated as Number' >&2 - exit 1 -fi -printf '%s\n' 'zero rejected as Number: PASS' - -if "$idris2" --check NegativeIsNotNumber.idric >negative.log 2>&1; then - printf '%s\n' 'negative literal unexpectedly elaborated as Number' >&2 - exit 1 -fi -printf '%s\n' 'negative value rejected as Number: PASS' - -if ! "$idris2" --check IdrisCompatibility.idr >compatibility.log 2>&1; then - cat compatibility.log >&2 - exit 1 -fi -printf '%s\n' 'ordinary .idr numeric inference preserved: PASS' From 078423fcb3eee302d0fb2b8a879e1f69a1659c58 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 11 Sep 2026 10:42:33 -0400 Subject: [PATCH 61/80] Reuse inherited number token mapping --- Parser/Source.idr | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/Parser/Source.idr b/Parser/Source.idr index 3d51eafe67..b6bc20a6bf 100644 --- a/Parser/Source.idr +++ b/Parser/Source.idr @@ -28,18 +28,18 @@ canonicalize_idric_namespace ns = unsafeFoldNamespace $ replace_data_text_namespace_components $ unsafeUnfoldNamespace ns -canonicalize_idric_token : Token -> Token -canonicalize_idric_token (Ident "choice") = Keyword "choice" -canonicalize_idric_token (Ident "Number") = Ident "Nat" -canonicalize_idric_token (Ident "Text") = Ident "String" -canonicalize_idric_token (Ident "ℕ") = Ident "Nat" -canonicalize_idric_token (DotSepIdent ns "Text") +canonicalizeIdricToken : Token -> Token +canonicalizeIdricToken (Ident "choice") = Keyword "choice" +canonicalizeIdricToken (Ident "Number") = canonicalizeIdricToken (Ident "ℕ") +canonicalizeIdricToken (Ident "Text") = Ident "String" +canonicalizeIdricToken (Ident "ℕ") = Ident "Nat" +canonicalizeIdricToken (DotSepIdent ns "Text") = if unsafeUnfoldNamespace ns == ["Data"] then DotSepIdent ns "String" else DotSepIdent (canonicalize_idric_namespace ns) "Text" -canonicalize_idric_token (DotSepIdent ns name) +canonicalizeIdricToken (DotSepIdent ns name) = DotSepIdent (canonicalize_idric_namespace ns) name -canonicalize_idric_token tok = tok +canonicalizeIdricToken tok = tok sourceSyntax : Maybe String -> SourceSyntax sourceSyntax (Just fname) = if isSuffixOf ".idric" fname @@ -50,7 +50,7 @@ sourceSyntax Nothing = IdrisSyntax sourceTokens : Maybe String -> List (WithBounds Token) -> List (WithBounds Token) sourceTokens (Just fname) toks = if isSuffixOf ".idric" fname - then map (map canonicalize_idric_token) toks + then map (map canonicalizeIdricToken) toks else toks sourceTokens Nothing toks = toks @@ -61,7 +61,7 @@ runParserToSource : {e : _} -> String -> Grammar ParsingState Token e ty -> Either Error (List Warning, State, ty) runParserToSource sourceFile origin lit reject str p - = do str <- mapFst (fromLitError origin) $ unlit lit str + = do str <- mapFst (fromLitError origin) $ unlit lit reject str (cs, toks) <- mapFst (fromLexError origin) $ lexToWith (sourceSyntax sourceFile) reject str (decs, ws, (parsed, _)) <- mapFst (fromParsingErrors origin) $ From f228187e606ae84e30ef2ddf43bdf9d7fb40a02f Mon Sep 17 00:00:00 2001 From: i Date: Fri, 11 Sep 2026 10:42:54 -0400 Subject: [PATCH 62/80] Keep parser behavior unchanged --- Parser/Source.idr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Parser/Source.idr b/Parser/Source.idr index b6bc20a6bf..04ec43c386 100644 --- a/Parser/Source.idr +++ b/Parser/Source.idr @@ -61,7 +61,7 @@ runParserToSource : {e : _} -> String -> Grammar ParsingState Token e ty -> Either Error (List Warning, State, ty) runParserToSource sourceFile origin lit reject str p - = do str <- mapFst (fromLitError origin) $ unlit lit reject str + = do str <- mapFst (fromLitError origin) $ unlit lit str (cs, toks) <- mapFst (fromLexError origin) $ lexToWith (sourceSyntax sourceFile) reject str (decs, ws, (parsed, _)) <- mapFst (fromParsingErrors origin) $ From 60d4a5b54afb6ec8071709ab9b9fd8ba76afc8d7 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 11 Sep 2026 10:44:08 -0400 Subject: [PATCH 63/80] =?UTF-8?q?Separate=20Idri=C3=A7=20token=20surface?= =?UTF-8?q?=20from=20Idris=20lowering?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Parser/Source.idr | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/Parser/Source.idr b/Parser/Source.idr index 04ec43c386..35701a3a0f 100644 --- a/Parser/Source.idr +++ b/Parser/Source.idr @@ -28,18 +28,27 @@ canonicalize_idric_namespace ns = unsafeFoldNamespace $ replace_data_text_namespace_components $ unsafeUnfoldNamespace ns +-- Keep the inherited Idris compatibility lowering intact. New Idriç spellings +-- are normalized to that existing boundary before this function runs. canonicalizeIdricToken : Token -> Token canonicalizeIdricToken (Ident "choice") = Keyword "choice" -canonicalizeIdricToken (Ident "Number") = canonicalizeIdricToken (Ident "ℕ") -canonicalizeIdricToken (Ident "Text") = Ident "String" canonicalizeIdricToken (Ident "ℕ") = Ident "Nat" -canonicalizeIdricToken (DotSepIdent ns "Text") +canonicalizeIdricToken tok = tok + +canonicalize_idric_surface_token : Token -> Token +canonicalize_idric_surface_token (Ident "Number") = Ident "ℕ" +canonicalize_idric_surface_token (Ident "Text") = Ident "String" +canonicalize_idric_surface_token (DotSepIdent ns "Text") = if unsafeUnfoldNamespace ns == ["Data"] then DotSepIdent ns "String" else DotSepIdent (canonicalize_idric_namespace ns) "Text" -canonicalizeIdricToken (DotSepIdent ns name) +canonicalize_idric_surface_token (DotSepIdent ns name) = DotSepIdent (canonicalize_idric_namespace ns) name -canonicalizeIdricToken tok = tok +canonicalize_idric_surface_token tok = tok + +canonicalize_idric_source_token : Token -> Token +canonicalize_idric_source_token token + = canonicalizeIdricToken (canonicalize_idric_surface_token token) sourceSyntax : Maybe String -> SourceSyntax sourceSyntax (Just fname) = if isSuffixOf ".idric" fname @@ -50,7 +59,7 @@ sourceSyntax Nothing = IdrisSyntax sourceTokens : Maybe String -> List (WithBounds Token) -> List (WithBounds Token) sourceTokens (Just fname) toks = if isSuffixOf ".idric" fname - then map (map canonicalizeIdricToken) toks + then map (map canonicalize_idric_source_token) toks else toks sourceTokens Nothing toks = toks From ea0adc686ca13c2802e070b1dba51462333142ca Mon Sep 17 00:00:00 2001 From: i Date: Fri, 11 Sep 2026 10:46:51 -0400 Subject: [PATCH 64/80] Keep inherited Vect koans at compatibility boundary --- _/koans/03-lists-and-length-indexed-lists/exercise/Main.idric | 2 +- _/koans/03-lists-and-length-indexed-lists/solution/Main.idric | 2 +- _/koans/06-implicit-dependent-results/exercise/Main.idric | 2 +- _/koans/06-implicit-dependent-results/solution/Main.idric | 2 +- _/koans/12-wegert-model/exercise/Main.idric | 2 +- _/koans/12-wegert-model/solution/Main.idric | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric b/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric index 5bfd478ee3..9dbdb817b3 100644 --- a/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric @@ -6,7 +6,7 @@ import Data.Vect numbers : List Number numbers = [2, 4, 6] -exactly_three : Vect 3 Number +exactly_three : Vect 3 ℕ exactly_three = ?three_values prepend : a → Vect n a → Vect (S n) a diff --git a/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric b/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric index 85b98d3248..f1bba66784 100644 --- a/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric @@ -6,7 +6,7 @@ import Data.Vect numbers : List Number numbers = [2, 4, 6] -exactly_three : Vect 3 Number +exactly_three : Vect 3 ℕ exactly_three = [2, 4, 6] prepend : a → Vect n a → Vect (S n) a diff --git a/_/koans/06-implicit-dependent-results/exercise/Main.idric b/_/koans/06-implicit-dependent-results/exercise/Main.idric index baf33de2e5..b0bf9e0e26 100644 --- a/_/koans/06-implicit-dependent-results/exercise/Main.idric +++ b/_/koans/06-implicit-dependent-results/exercise/Main.idric @@ -3,7 +3,7 @@ module Main import Data.Vect -- n is inferred from values; the result type depends on that inferred value. -prepend : {n : Number} → a → Vect n a → Vect (S n) a +prepend : {n : ℕ} → a → Vect n a → Vect (S n) a prepend item items = ?dependent_result main : IO () diff --git a/_/koans/06-implicit-dependent-results/solution/Main.idric b/_/koans/06-implicit-dependent-results/solution/Main.idric index a2cd47b03d..b86221891c 100644 --- a/_/koans/06-implicit-dependent-results/solution/Main.idric +++ b/_/koans/06-implicit-dependent-results/solution/Main.idric @@ -2,7 +2,7 @@ module Main import Data.Vect -prepend : {n : Number} → a → Vect n a → Vect (S n) a +prepend : {n : ℕ} → a → Vect n a → Vect (S n) a prepend item items = item :: items main : IO () diff --git a/_/koans/12-wegert-model/exercise/Main.idric b/_/koans/12-wegert-model/exercise/Main.idric index f8eaa88e1c..3df42502d7 100644 --- a/_/koans/12-wegert-model/exercise/Main.idric +++ b/_/koans/12-wegert-model/exercise/Main.idric @@ -26,7 +26,7 @@ describe_point : placed_point → Text describe_point (zero_at coordinate) = "zero at " ++ show coordinate describe_point (pole_at coordinate) = "pole at " ++ show coordinate -first_description : placement_kind → Number → Vect n placed_point → Text +first_description : placement_kind → ℕ → Vect n placed_point → String first_description kind coordinate points = let (updated ** first_is_new) = place kind coordinate points in describe_point (Vect.head updated) diff --git a/_/koans/12-wegert-model/solution/Main.idric b/_/koans/12-wegert-model/solution/Main.idric index 848f155397..809b69d4ed 100644 --- a/_/koans/12-wegert-model/solution/Main.idric +++ b/_/koans/12-wegert-model/solution/Main.idric @@ -27,7 +27,7 @@ describe_point : placed_point → Text describe_point (zero_at coordinate) = "zero at " ++ show coordinate describe_point (pole_at coordinate) = "pole at " ++ show coordinate -first_description : placement_kind → Number → Vect n placed_point → Text +first_description : placement_kind → ℕ → Vect n placed_point → String first_description kind coordinate points = let (updated ** first_is_new) = place kind coordinate points in describe_point (Vect.head updated) From 681aad65ad0af42994ba96470fa5465992c12ee0 Mon Sep 17 00:00:00 2001 From: i Date: Fri, 11 Sep 2026 22:21:32 -0400 Subject: [PATCH 65/80] Record resource interface deep-dive model --- notes/resource-interface-deep-dive.md | 224 ++++++++++++++++++++++++++ 1 file changed, 224 insertions(+) create mode 100644 notes/resource-interface-deep-dive.md diff --git a/notes/resource-interface-deep-dive.md b/notes/resource-interface-deep-dive.md new file mode 100644 index 0000000000..7caa7225a8 --- /dev/null +++ b/notes/resource-interface-deep-dive.md @@ -0,0 +1,224 @@ +# Resource interfaces and deep-dive levels + +This is a design note, not a claim that every example phrase is accepted by the +current parser. + +It extends the existing Idriç rule that purpose belongs above mechanism. The +same rule should hold for operating-system resources and devices: a program +should not have to expose whether Linux eventually implements an operation with +`read`, `write`, `ioctl`, `mmap`, a pseudo-file, or another kernel interface +until the reader deliberately descends to that implementation layer. + +## Keep the program's purpose at the top + +Programs may begin with titles or actions such as: + +```idric +beep a sound +turn screen red +turn one pixel red +``` + +Those are different purposes. Their deeper implementations should be inspectable +without replacing the top-level purpose with syscall vocabulary. + +For example, one level down might say: + +```idric +beep a sound ≝ + audio ← open default audio output + write tone to audio + close audio +``` + +while a display action might say: + +```idric +turn screen red ≝ + screen ← open display + write red to screen + close screen +``` + +and a single-pixel action might descend through a position explicitly: + +```idric +turn one pixel red at location ≝ + screen ← open display + seek screen.pixels to location + write red to screen.pixels + close screen +``` + +The examples are intentionally parallel. A reader studying audio and display +work should be able to descend through roughly comparable conceptual levels +instead of encountering unrelated API shapes merely because Linux exposes the +hardware through different historical mechanisms. + +## A descriptor can be a common handle without becoming the conceptual model + +On Linux, `ioctl` is not an alternative to going through the kernel. `read`, +`write`, `ioctl`, `mmap`, and related calls are all kernel interfaces, and +`ioctl` usually operates on a file descriptor. + +A descriptor is therefore a plausible common lower-level handle for many +resources. That does not require the language-facing operation to be named after +the descriptor or after `ioctl`. + +A deeper implementation can eventually expose something like: + +```text +descriptor ← open device +configure descriptor with Linux request +write bytes to descriptor +map descriptor +close descriptor +``` + +and then descend again into the exact syscall ABI, request numbers, structures, +driver boundary, and hardware behavior. + +Do not merely expand `ioctl` to “input/output control” as a public semantic +name. That explains the acronym without explaining the operation. + +## Make device resources resemble file resources where the semantics agree + +A useful direction is to treat a device as a structured resource with named +subresources or properties: + +```text +audio + samples + sample rate + channels + format + state + +screen + pixels + width + height + format + +camera + frames + width + height + format + state +``` + +Then a small shared action vocabulary can remain familiar: + +```text +open +read +write +seek +map +wait +close +``` + +For example: + +```idric +rate ← read audio.sample rate +write 48000 to audio.sample rate +write samples to audio.samples + +width ← read screen.width +seek screen.pixels to location +write red to screen.pixels +``` + +The implementation of `write 48000 to audio.sample rate` may eventually lower +to an `ioctl`, while writing audio samples may lower to `write`, and mapping +screen pixels may lower to `mmap`. That implementation distinction belongs +below the semantic operation. + +This is filesystem-like, but it should not falsely claim that every resource is +just an untyped byte file. The common surface should preserve meaningful +differences such as readable, writable, seekable, mappable, or waitable +resources and the semantic type of the values they carry. + +Possible examples include: + +```text +audio.sample rate : writable Frequency +screen.width : readable Pixel Count +screen.pixels : seekable Pixel +accelerometer : readable Acceleration +``` + +The exact type vocabulary remains a design question. The important rule is that +types describe the domain rather than exposing a raw request number, pointer, +or byte layout merely because the Linux implementation uses one. + +## `ioctl` belongs at the Linux boundary + +At the deepest Linux wrapper, `ioctl` still needs a careful typed model. Request +codes can imply whether the kernel reads an argument, writes one, does both, or +uses no transferred structure. That is a useful place for the type system to +prevent mismatched request codes, structures, directions, and sizes. + +That safety work should not turn `ioctl` into the identity of a higher-level +audio, display, camera, terminal, or network operation. + +The descent should remain conceptually similar to: + +```text +beep a sound + ↓ +write tone to audio + ↓ +write sample rate to audio.sample rate +write samples to audio.samples + ↓ +Linux ioctl / write + ↓ +syscall ABI + ↓ +kernel driver + ↓ +hardware +``` + +and, in parallel: + +```text +turn one pixel red + ↓ +seek screen.pixels to location +write red to screen.pixels + ↓ +Linux mmap / write / ioctl as required + ↓ +syscall ABI + ↓ +kernel driver + ↓ +hardware +``` + +The point of the layers is not to hide lower levels permanently. It is to let a +person stop at the level that answers the current question and descend further +only when the deeper mechanism matters. + +## Design questions to keep open + +- How visible should file descriptors be in ordinary low-level Idriç source? +- Which operations genuinely share `read`, `write`, `seek`, `map`, and `wait` + semantics, and which need distinct domain actions? +- Should named device properties such as `audio.sample rate` behave as first- + class resources, lenses/views onto a resource, or something else? +- How should read-only, write-only, seekable, mappable, and waitable capabilities + appear in types without turning simple source into type-system ceremony? +- Where should Linux-specific `ioctl` request descriptions live so another + backend can implement the same semantic operation without inheriting Linux + vocabulary? +- How should deep-dive filesystem layout make the relation between the semantic + action and its Linux implementation easy to follow? + +The implementation mechanism is allowed to differ. The conceptual level shown +to the programmer should differ only when the meaning differs. \ No newline at end of file From 8f86736f752acaafbbf529af89a5c9ae90cf6e0b Mon Sep 17 00:00:00 2001 From: i Date: Sat, 12 Sep 2026 05:23:53 -0400 Subject: [PATCH 66/80] Bind complex/projective parameters explicitly --- .../ComplexProjective.idric | 40 ++++++++++++++----- 1 file changed, 30 insertions(+), 10 deletions(-) diff --git a/_/examples/unified-higher-mathematics/ComplexProjective.idric b/_/examples/unified-higher-mathematics/ComplexProjective.idric index bd94d9453e..37e9a06546 100644 --- a/_/examples/unified-higher-mathematics/ComplexProjective.idric +++ b/_/examples/unified-higher-mathematics/ComplexProjective.idric @@ -14,10 +14,13 @@ import MathematicalSpaces -- An element of C^n has n complex coordinates. Dimension is part of the type, -- so a C^2 value cannot be consumed where C^3 is required. -export +public export data ComplexCoordinates : Type → CoordinateRank → Type where - NoComplexCoordinates : ComplexCoordinates complex Z + NoComplexCoordinates : + {complex : Type} → + ComplexCoordinates complex Z ComplexCoordinate : + {complex : Type} → {remaining : CoordinateRank} → complex → ComplexCoordinates complex remaining → @@ -25,6 +28,9 @@ data ComplexCoordinates : Type → CoordinateRank → Type where export map_complex_coordinates : + {source : Type} → + {target : Type} → + {dimension : CoordinateRank} → (map_coordinate : source → target) → ComplexCoordinates source dimension → ComplexCoordinates target dimension @@ -37,8 +43,10 @@ map_complex_coordinates (map_coordinate coordinate) (map_complex_coordinates map_coordinate remaining) -export +public export scale_complex_coordinates : + {complex : Type} → + {dimension : CoordinateRank} → (multiply_complex : complex → complex → complex) → complex → ComplexCoordinates complex dimension → @@ -59,7 +67,7 @@ scale_complex_coordinates -- fake generic proof that an arbitrary complex carrier can decide nonzeroness. -- Concrete complex arithmetic should expose checked constructors appropriate -- to its scalar semantics. -export +public export record NonzeroComplexScalar (complex : Type) where constructor UnsafeKnownNonzeroComplexScalar nonzero_complex_value : complex @@ -68,7 +76,7 @@ record NonzeroComplexScalar (complex : Type) where -- excluded. The witness constructor is unsafe for the same reason as above: -- nonzeroness belongs to the concrete complex carrier, not to this structural -- module. -export +public export record NonzeroHomogeneousCoordinates (complex : Type) (projective_dimension : CoordinateRank) where @@ -80,14 +88,18 @@ record NonzeroHomogeneousCoordinates -- semantics. There is deliberately no Eq instance and no vector addition or -- multiplication on this type. Common nonzero complex rescaling is expressed -- by the witness type below. -export +public export data ComplexProjectivePoint : Type → CoordinateRank → Type where UnsafeProjectiveClass : + {complex : Type} → + {projective_dimension : CoordinateRank} → NonzeroHomogeneousCoordinates complex projective_dimension → ComplexProjectivePoint complex projective_dimension export homogeneous_representative : + {complex : Type} → + {projective_dimension : CoordinateRank} → ComplexProjectivePoint complex projective_dimension → NonzeroHomogeneousCoordinates complex projective_dimension homogeneous_representative (UnsafeProjectiveClass representative) = @@ -100,8 +112,10 @@ homogeneous_representative (UnsafeProjectiveClass representative) = -- coordinate by coordinate. Projective equivalence is the existence of such -- a nonzero lambda. Keeping the scale as explicit evidence prevents raw -- component equality from being mistaken for equality in CP^n. -export +public export projective_rescaling_witness : + {complex : Type} → + {projective_dimension : CoordinateRank} → (multiply_complex : complex → complex → complex) → (scale : NonzeroComplexScalar complex) → (left : NonzeroHomogeneousCoordinates complex projective_dimension) → @@ -117,8 +131,10 @@ projective_rescaling_witness -- (z1,...,zn) maps to [1:z1:...:zn]. The first homogeneous coordinate is -- supplied as a known-nonzero complex scalar rather than inferred from a -- machine representation. -export +public export affine_to_projective : + {complex : Type} → + {projective_dimension : CoordinateRank} → NonzeroComplexScalar complex → ComplexCoordinates complex projective_dimension → ComplexProjectivePoint complex projective_dimension @@ -131,8 +147,10 @@ affine_to_projective (nonzero_complex_value one) affine_coordinates -private +public export divide_coordinates_by : + {complex : Type} → + {dimension : CoordinateRank} → (divide_complex : complex → complex → complex) → complex → ComplexCoordinates complex dimension → @@ -150,8 +168,10 @@ divide_coordinates_by -- Extract the affine chart with first homogeneous coordinate nonzero. The -- operation is partial: [0:z1:...:zn] is outside this chart. In particular, -- [0:1] in CP^1 is the point at infinity and returns Nothing here. -export +public export projective_first_chart : + {complex : Type} → + {projective_dimension : CoordinateRank} → (is_zero_complex : complex → Bool) → (divide_complex : complex → complex → complex) → ComplexProjectivePoint complex projective_dimension → From 221c48a3822a4dad8a4f6540bd12d1a9a0a18b93 Mon Sep 17 00:00:00 2001 From: i Date: Sat, 12 Sep 2026 11:30:27 -0400 Subject: [PATCH 67/80] Run maintained CI on self-hosted Debian --- .github/workflows/ci-edric-build.yml | 3 ++- .github/workflows/ci-source-layout.yml | 3 ++- .github/workflows/ci_idric_style.yml | 3 ++- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci-edric-build.yml b/.github/workflows/ci-edric-build.yml index 83ad1f01e2..7873a10188 100644 --- a/.github/workflows/ci-edric-build.yml +++ b/.github/workflows/ci-edric-build.yml @@ -9,7 +9,8 @@ permissions: jobs: compiler: - runs-on: ubuntu-latest + if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name == github.repository + runs-on: [self-hosted, linux, debian] steps: - uses: actions/checkout@v4 - name: Install host build tools diff --git a/.github/workflows/ci-source-layout.yml b/.github/workflows/ci-source-layout.yml index 7539590213..0b6a170fa6 100644 --- a/.github/workflows/ci-source-layout.yml +++ b/.github/workflows/ci-source-layout.yml @@ -9,7 +9,8 @@ permissions: jobs: layout: - runs-on: ubuntu-latest + if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name == github.repository + runs-on: [self-hosted, linux, debian] steps: - uses: actions/checkout@v4 - name: Verify flattened source layout diff --git a/.github/workflows/ci_idric_style.yml b/.github/workflows/ci_idric_style.yml index 77cdbaa827..8a44717a1f 100644 --- a/.github/workflows/ci_idric_style.yml +++ b/.github/workflows/ci_idric_style.yml @@ -9,7 +9,8 @@ permissions: jobs: style: - runs-on: ubuntu-latest + if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name == github.repository + runs-on: [self-hosted, linux, debian] steps: - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 with: From 99b700a353043101dafacc58241d93479655a8cb Mon Sep 17 00:00:00 2001 From: i Date: Mon, 14 Sep 2026 09:11:25 -0400 Subject: [PATCH 68/80] Run maintained CI on GitHub-hosted Ubuntu --- .github/workflows/ci-edric-build.yml | 3 +-- .github/workflows/ci-source-layout.yml | 3 +-- .github/workflows/ci_idric_style.yml | 3 +-- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/.github/workflows/ci-edric-build.yml b/.github/workflows/ci-edric-build.yml index 7873a10188..83ad1f01e2 100644 --- a/.github/workflows/ci-edric-build.yml +++ b/.github/workflows/ci-edric-build.yml @@ -9,8 +9,7 @@ permissions: jobs: compiler: - if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name == github.repository - runs-on: [self-hosted, linux, debian] + runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 - name: Install host build tools diff --git a/.github/workflows/ci-source-layout.yml b/.github/workflows/ci-source-layout.yml index 0b6a170fa6..7539590213 100644 --- a/.github/workflows/ci-source-layout.yml +++ b/.github/workflows/ci-source-layout.yml @@ -9,8 +9,7 @@ permissions: jobs: layout: - if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name == github.repository - runs-on: [self-hosted, linux, debian] + runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 - name: Verify flattened source layout diff --git a/.github/workflows/ci_idric_style.yml b/.github/workflows/ci_idric_style.yml index 8a44717a1f..77cdbaa827 100644 --- a/.github/workflows/ci_idric_style.yml +++ b/.github/workflows/ci_idric_style.yml @@ -9,8 +9,7 @@ permissions: jobs: style: - if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name == github.repository - runs-on: [self-hosted, linux, debian] + runs-on: ubuntu-latest steps: - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 with: From a99440a21a8447bd7b0d5baab13c96de408cefaf Mon Sep 17 00:00:00 2001 From: i Date: Mon, 14 Sep 2026 10:10:54 -0400 Subject: [PATCH 69/80] Remove stale Cardinality wording from form semantics --- _/examples/unified-higher-mathematics/QUADRATIC-FORMS.md | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md b/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md index 3dea4b1ffb..f1db4e4835 100644 --- a/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md +++ b/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md @@ -208,10 +208,9 @@ library-level code. Existing dependent indices and ordinary equality proofs are enough for this slice. The source itself follows the current Idriç surface used by the higher-math -foundation: `±Number`, `Cardinality`/`CoordinateRank`, Unicode `→`, snake_case -operations, and implicit file totality. The compiler support for that surface is -provided by the source-style work on which this form branch is stacked; the -form API does not deform its mathematics around the older Idris vocabulary. +foundation: exact signed values use `±Number`, rank/count indices use `Number`, +and Idriç-facing source uses Unicode `→`, snake_case operations, and implicit +file totality. No separate `Cardinality` type is introduced. A future generalization should improve the mathematical library layer first: law-bearing scalar/ring/field and involution structures, modules, bases, linear From 941efa0ac94233c6a7544287b862db29864fe320 Mon Sep 17 00:00:00 2001 From: i Date: Mon, 14 Sep 2026 17:34:06 -0400 Subject: [PATCH 70/80] Restore standalone presheaf integer labels --- .../unified-higher-mathematics/PresheafRestriction.idric | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/_/examples/unified-higher-mathematics/PresheafRestriction.idric b/_/examples/unified-higher-mathematics/PresheafRestriction.idric index 3eb8f4a5fd..eaaf9741aa 100644 --- a/_/examples/unified-higher-mathematics/PresheafRestriction.idric +++ b/_/examples/unified-higher-mathematics/PresheafRestriction.idric @@ -18,9 +18,9 @@ data Included : Open → Open → Type where public export data Section : Open → Type where - WholeSection : ±Number → Section Whole - PatchSection : ±Number → Section Patch - PointSection : ±Number → Section Point + WholeSection : Integer → Section Whole + PatchSection : Integer → Section Patch + PointSection : Integer → Section Point public export restrict : {u, v : Open} → Included v u → Section u → Section v From 4d13f5b30db6f2f5d2d353b7e478e225e2748131 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 15 Sep 2026 05:16:07 -0400 Subject: [PATCH 71/80] Repair higher-math acceptance labels --- .../unified-higher-mathematics/Tests.idric | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/_/examples/unified-higher-mathematics/Tests.idric b/_/examples/unified-higher-mathematics/Tests.idric index b781b60caa..c29b440ccc 100644 --- a/_/examples/unified-higher-mathematics/Tests.idric +++ b/_/examples/unified-higher-mathematics/Tests.idric @@ -54,7 +54,7 @@ failing "Mismatch between: PlaneName and ImagePlaneName." equal_rank_named_spaces_do_not_unify : ExactVectorSample image_plane_space equal_rank_named_spaces_do_not_unify = plane_vector 1 2 -failing "Mismatch between: 0 and S" +failing "Mismatch between: 0 and 1." one_name_cannot_claim_a_different_rank : FiniteSpace one_name_cannot_claim_a_different_rank = NamedFiniteSpace {rank = 3} PlaneName @@ -294,16 +294,16 @@ r128_quarter_turn_preserves_coordinate_128_test = Refl north_pole_is_s2_test : UnitSpherePoint real_three_euclidean north_pole_is_s2_test = north_pole_s2 -sphere_s0_h0_rank_test : sphere_integral_cohomology_rank 0 0 = the Cardinality 2 +sphere_s0_h0_rank_test : sphere_integral_cohomology_rank 0 0 = the Number 2 sphere_s0_h0_rank_test = Refl -sphere_s2_h0_rank_test : sphere_integral_cohomology_rank 2 0 = the Cardinality 1 +sphere_s2_h0_rank_test : sphere_integral_cohomology_rank 2 0 = the Number 1 sphere_s2_h0_rank_test = Refl -sphere_s2_h1_rank_test : sphere_integral_cohomology_rank 2 1 = the Cardinality 0 +sphere_s2_h1_rank_test : sphere_integral_cohomology_rank 2 1 = the Number 0 sphere_s2_h1_rank_test = Refl -sphere_s2_h2_rank_test : sphere_integral_cohomology_rank 2 2 = the Cardinality 1 +sphere_s2_h2_rank_test : sphere_integral_cohomology_rank 2 2 = the Number 1 sphere_s2_h2_rank_test = Refl odd_sphere_euler_test : sphere_euler_characteristic 3 = the ±Number 0 @@ -331,30 +331,30 @@ unit_quaternion_rotation_action_test : (three_vector 0 1 0) = three_vector 0 (-1) 0 unit_quaternion_rotation_action_test = Refl -cp3_real_dimension_test : cp_real_dimension 3 = the Cardinality 6 +cp3_real_dimension_test : cp_real_dimension 3 = the Number 6 cp3_real_dimension_test = Refl -cp3_hopf_sphere_dimension_test : cp_hopf_sphere_dimension 3 = the Cardinality 7 +cp3_hopf_sphere_dimension_test : cp_hopf_sphere_dimension 3 = the Number 7 cp3_hopf_sphere_dimension_test = Refl -cp2_h0_rank_test : cp_integral_cohomology_rank 2 0 = the Cardinality 1 +cp2_h0_rank_test : cp_integral_cohomology_rank 2 0 = the Number 1 cp2_h0_rank_test = Refl -cp2_h2_rank_test : cp_integral_cohomology_rank 2 2 = the Cardinality 1 +cp2_h2_rank_test : cp_integral_cohomology_rank 2 2 = the Number 1 cp2_h2_rank_test = Refl -cp2_h4_rank_test : cp_integral_cohomology_rank 2 4 = the Cardinality 1 +cp2_h4_rank_test : cp_integral_cohomology_rank 2 4 = the Number 1 cp2_h4_rank_test = Refl -cp2_h3_rank_test : cp_integral_cohomology_rank 2 3 = the Cardinality 0 +cp2_h3_rank_test : cp_integral_cohomology_rank 2 3 = the Number 0 cp2_h3_rank_test = Refl -cp2_h6_rank_test : cp_integral_cohomology_rank 2 6 = the Cardinality 0 +cp2_h6_rank_test : cp_integral_cohomology_rank 2 6 = the Number 0 cp2_h6_rank_test = Refl r3_one_point_compactifies_to_s3_test : compactified_sphere_dimension (euclidean_one_point_compactification 3) = - the Cardinality 3 + the Number 3 r3_one_point_compactifies_to_s3_test = Refl -- -------------------------------------------------------------------------- From afeac213ef459532ea4a909065fe516d02a3bb94 Mon Sep 17 00:00:00 2001 From: i Date: Tue, 15 Sep 2026 22:05:06 -0400 Subject: [PATCH 72/80] =?UTF-8?q?Use=20=C2=B1Number=20in=20presheaf=20fixt?= =?UTF-8?q?ure?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../PresheafRestriction.idric | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/_/examples/unified-higher-mathematics/PresheafRestriction.idric b/_/examples/unified-higher-mathematics/PresheafRestriction.idric index eaaf9741aa..54523cf7a3 100644 --- a/_/examples/unified-higher-mathematics/PresheafRestriction.idric +++ b/_/examples/unified-higher-mathematics/PresheafRestriction.idric @@ -1,10 +1,13 @@ module PresheafRestriction +import MathematicalSpaces + %unbound_implicits off -- A finite restriction experiment, separate from the Euclidean geometry --- model. It records only three opens, their inclusions, and integer-labelled --- sections. It is not a general presheaf interface and makes no sheaf claim. +-- model. It records only three opens, their inclusions, and signed-number- +-- labelled sections. It is not a general presheaf interface and makes no +-- sheaf claim. public export data Open = Whole | Patch | Point @@ -18,9 +21,9 @@ data Included : Open → Open → Type where public export data Section : Open → Type where - WholeSection : Integer → Section Whole - PatchSection : Integer → Section Patch - PointSection : Integer → Section Point + WholeSection : ±Number → Section Whole + PatchSection : ±Number → Section Patch + PointSection : ±Number → Section Point public export restrict : {u, v : Open} → Included v u → Section u → Section v From a8d2f0e0554bb61be327da39e47b46ccb965bde6 Mon Sep 17 00:00:00 2001 From: i Date: Wed, 16 Sep 2026 10:45:39 -0400 Subject: [PATCH 73/80] Make repository commands cwd-independent --- _/AGENTS.md | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/_/AGENTS.md b/_/AGENTS.md index 2d48ab91fe..0b2dd80f72 100644 --- a/_/AGENTS.md +++ b/_/AGENTS.md @@ -7,6 +7,14 @@ guidance. Read [EDRIC.md](EDRIC.md) and [BRANCHES.md](BRANCHES.md) before changing this repository. +## Human-facing scripts + +Whenever giving the human a script or command block, assume `$PWD` is arbitrary. +Resolve repository and file paths from the script's own location, an explicit +project location, or a discovered repository root, and perform any required +`cd` inside the script. Never require the human to `cd` first or rely on relative +paths against their current working directory. + ## Identify the compiler line first - `Idriç` is the default branch and the canonical modern compiler line. It is @@ -22,12 +30,14 @@ repository. repositories. A backend integration branch here must state the exact core compiler contract it is integrating. -Before editing, run: +Before editing, resolve `repo_root` to the absolute path of the intended Idriç +checkout without assuming the caller's current directory. Then run: ```sh -git fetch origin --prune -git status --short --branch -git worktree list +: "${repo_root:?repo_root must be the absolute Idriç checkout path}" +git -C "$repo_root" fetch origin --prune +git -C "$repo_root" status --short --branch +git -C "$repo_root" worktree list ``` Do not switch, reset, stash, rebase, or overwrite a dirty worktree merely to From 49ac0bac7d905c7f7ba970ef13cd10672d58ae8e Mon Sep 17 00:00:00 2001 From: i Date: Wed, 16 Sep 2026 12:46:11 -0400 Subject: [PATCH 74/80] Generalize presheaf section payloads --- .../PresheafRestriction.idric | 102 ++++++++++++++---- 1 file changed, 79 insertions(+), 23 deletions(-) diff --git a/_/examples/unified-higher-mathematics/PresheafRestriction.idric b/_/examples/unified-higher-mathematics/PresheafRestriction.idric index 54523cf7a3..1363605648 100644 --- a/_/examples/unified-higher-mathematics/PresheafRestriction.idric +++ b/_/examples/unified-higher-mathematics/PresheafRestriction.idric @@ -5,9 +5,10 @@ import MathematicalSpaces %unbound_implicits off -- A finite restriction experiment, separate from the Euclidean geometry --- model. It records only three opens, their inclusions, and signed-number- --- labelled sections. It is not a general presheaf interface and makes no --- sheaf claim. +-- model. It records only three opens, their inclusions, and sections carrying +-- an arbitrary payload. Restriction moves the payload between opens without +-- inspecting or interpreting it. It is not a general presheaf interface and +-- makes no sheaf claim. public export data Open = Whole | Patch | Point @@ -20,26 +21,90 @@ data Included : Open → Open → Type where PointWhole : Included Point Whole public export -data Section : Open → Type where - WholeSection : ±Number → Section Whole - PatchSection : ±Number → Section Patch - PointSection : ±Number → Section Point +data Section : Type → Open → Type where + WholeSection : payload → Section payload Whole + PatchSection : payload → Section payload Patch + PointSection : payload → Section payload Point public export -restrict : {u, v : Open} → Included v u → Section u → Section v +restrict : + {payload : Type} → + {u, v : Open} → + Included v u → Section payload u → Section payload v restrict Same section = section restrict PatchWhole (WholeSection value) = PatchSection value restrict PointPatch (PatchSection value) = PointSection value restrict PointWhole (WholeSection value) = PointSection value --- This is deliberately only a formal pair of elementary sections over one --- open. It does not construct a balanced tensor product, sums of elementary --- tensors, or a quotient by bilinearity relations. +public export +compose_included : + {u, v, w : Open} → Included w v → Included v u → Included w u +compose_included Same inclusion = inclusion +compose_included PatchWhole Same = PatchWhole +compose_included PointPatch Same = PointPatch +compose_included PointPatch PatchWhole = PointWhole +compose_included PointWhole Same = PointWhole + +public export +restriction_identity : + {payload : Type} → + {u : Open} → + (section : Section payload u) → + restrict Same section = section +restriction_identity section = Refl + +public export +restriction_composition : + {payload : Type} → + {u, v, w : Open} → + (wv : Included w v) → + (vu : Included v u) → + (section : Section payload u) → + restrict wv (restrict vu section) + = restrict (compose_included wv vu) section +restriction_composition Same vu section = Refl +restriction_composition PatchWhole Same section = Refl +restriction_composition PointPatch Same section = Refl +restriction_composition + PointPatch + PatchWhole + (WholeSection value) = Refl +restriction_composition PointWhole Same section = Refl + +-- A pair of signed numbers is a second payload example. It is deliberately not +-- called a complex number here: this fixture establishes only that restriction +-- is independent of the structure carried by a section. Pair arithmetic comes +-- later. +public export +SignedNumberPair : Type +SignedNumberPair = (±Number, ±Number) + +public export +pair_whole_section : Section SignedNumberPair Whole +pair_whole_section = WholeSection (2, 3) + +public export +pair_restriction_example : + restrict PatchWhole pair_whole_section = PatchSection (2, 3) +pair_restriction_example = Refl + +public export +pair_restriction_composition_example : + restrict PointPatch (restrict PatchWhole pair_whole_section) + = restrict PointWhole pair_whole_section +pair_restriction_composition_example = + restriction_composition PointPatch PatchWhole pair_whole_section + +-- This is deliberately only a formal pair of elementary signed-number +-- sections over one open. It remains a separate algebra example rather than +-- part of the payload-independent restriction machinery above. It does not +-- construct a balanced tensor product, sums of elementary tensors, or a +-- quotient by bilinearity relations. public export data ElementaryTensorSection : Open → Type where TensorSection : {u : Open} → - Section u → Section u → ElementaryTensorSection u + Section ±Number u → Section ±Number u → ElementaryTensorSection u public export restrict_tensor : @@ -57,8 +122,8 @@ public export tensor_restriction_pointwise : {u, v : Open} → (inclusion : Included v u) → - (left : Section u) → - (right : Section u) → + (left : Section ±Number u) → + (right : Section ±Number u) → restrict_tensor inclusion (TensorSection left right) = TensorSection (restrict inclusion left) (restrict inclusion right) tensor_restriction_pointwise Same left right = Refl @@ -69,15 +134,6 @@ tensor_restriction_pointwise tensor_restriction_pointwise PointWhole (WholeSection left) (WholeSection right) = Refl -public export -compose_included : - {u, v, w : Open} → Included w v → Included v u → Included w u -compose_included Same inclusion = inclusion -compose_included PatchWhole Same = PatchWhole -compose_included PointPatch Same = PointPatch -compose_included PointPatch PatchWhole = PointWhole -compose_included PointWhole Same = PointWhole - -- Identity restriction reduces definitionally, including when the formal pair -- is opaque to the caller. public export From 6e48b66befaa0dd946e63584bbb286257a22abb0 Mon Sep 17 00:00:00 2001 From: i Date: Wed, 16 Sep 2026 15:03:19 -0400 Subject: [PATCH 75/80] Fix explicit presheaf payload binders --- .../unified-higher-mathematics/PresheafRestriction.idric | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/_/examples/unified-higher-mathematics/PresheafRestriction.idric b/_/examples/unified-higher-mathematics/PresheafRestriction.idric index 1363605648..6e8bf19b52 100644 --- a/_/examples/unified-higher-mathematics/PresheafRestriction.idric +++ b/_/examples/unified-higher-mathematics/PresheafRestriction.idric @@ -22,9 +22,9 @@ data Included : Open → Open → Type where public export data Section : Type → Open → Type where - WholeSection : payload → Section payload Whole - PatchSection : payload → Section payload Patch - PointSection : payload → Section payload Point + WholeSection : {payload : Type} → payload → Section payload Whole + PatchSection : {payload : Type} → payload → Section payload Patch + PointSection : {payload : Type} → payload → Section payload Point public export restrict : From d9cf9732cc68bf1af677f13befb05d07e43561d5 Mon Sep 17 00:00:00 2001 From: i Date: Wed, 16 Sep 2026 15:28:31 -0400 Subject: [PATCH 76/80] Add pair arithmetic construction example --- .../PairArithmetic.idric | 69 +++++++++++++++++++ .../PairArithmeticTests.idric | 24 +++++++ _/tests/idris2/basic/edric009/expected | 1 + _/tests/idris2/basic/edric009/run | 14 ++++ 4 files changed, 108 insertions(+) create mode 100644 _/examples/unified-higher-mathematics/PairArithmetic.idric create mode 100644 _/examples/unified-higher-mathematics/PairArithmeticTests.idric diff --git a/_/examples/unified-higher-mathematics/PairArithmetic.idric b/_/examples/unified-higher-mathematics/PairArithmetic.idric new file mode 100644 index 0000000000..b5c5b8b61b --- /dev/null +++ b/_/examples/unified-higher-mathematics/PairArithmetic.idric @@ -0,0 +1,69 @@ +module PairArithmetic + +import MathematicalSpaces + +%unbound_implicits off + +-- The pair construction is independent of presheaf restriction. Its carrier +-- operations are supplied explicitly, so the construction does not choose a +-- machine representation or identify an arbitrary pair with a number system. +public export +pair_add : + {scalar : Type} → + (add : scalar → scalar → scalar) → + (scalar, scalar) → + (scalar, scalar) → + (scalar, scalar) +pair_add add (first, second) (third, fourth) = + (add first third, add second fourth) + +-- This is the familiar multiplication rule obtained by adjoining a symbol +-- whose square is -1: +-- +-- (a, b)(c, d) = (ac - bd, ad + bc). +-- +-- The rule is useful before naming any particular carrier C. For example, +-- applying it to pairs of signed whole numbers gives the Gaussian-integer +-- acceptance slice, not all mathematical complex numbers. +public export +pair_complex_multiply : + {scalar : Type} → + (add : scalar → scalar → scalar) → + (subtract : scalar → scalar → scalar) → + (multiply : scalar → scalar → scalar) → + (scalar, scalar) → + (scalar, scalar) → + (scalar, scalar) +pair_complex_multiply + add + subtract + multiply + (a, b) + (c, d) = + ( subtract (multiply a c) (multiply b d) + , add (multiply a d) (multiply b c) + ) + +signed_add : ±Number → ±Number → ±Number +signed_add left right = left + right + +signed_subtract : ±Number → ±Number → ±Number +signed_subtract left right = left - right + +signed_multiply : ±Number → ±Number → ±Number +signed_multiply left right = left * right + +public export +signed_pair_add : + (±Number, ±Number) → + (±Number, ±Number) → + (±Number, ±Number) +signed_pair_add = pair_add signed_add + +public export +signed_pair_complex_multiply : + (±Number, ±Number) → + (±Number, ±Number) → + (±Number, ±Number) +signed_pair_complex_multiply = + pair_complex_multiply signed_add signed_subtract signed_multiply diff --git a/_/examples/unified-higher-mathematics/PairArithmeticTests.idric b/_/examples/unified-higher-mathematics/PairArithmeticTests.idric new file mode 100644 index 0000000000..0d93698726 --- /dev/null +++ b/_/examples/unified-higher-mathematics/PairArithmeticTests.idric @@ -0,0 +1,24 @@ +module PairArithmeticTests + +import MathematicalSpaces +import PairArithmetic + +%unbound_implicits off + +signed_pair_add_test : + signed_pair_add (2, 3) (5, (-1)) = (7, 2) +signed_pair_add_test = Refl + +signed_pair_multiplicative_identity_test : + signed_pair_complex_multiply (2, 3) (1, 0) = (2, 3) +signed_pair_multiplicative_identity_test = Refl + +-- The pair (0, 1) behaves as the adjoined square root of -1 under the pair +-- multiplication rule. This checks the construction without claiming that +-- signed-number pairs exhaust C. +signed_pair_i_squared_test : + signed_pair_complex_multiply (0, 1) (0, 1) = ((-1), 0) +signed_pair_i_squared_test = Refl + +main : IO () +main = putStrLn "pair arithmetic construction: PASS" diff --git a/_/tests/idris2/basic/edric009/expected b/_/tests/idris2/basic/edric009/expected index b5fe2a7d2d..0f2f2c695e 100644 --- a/_/tests/idris2/basic/edric009/expected +++ b/_/tests/idris2/basic/edric009/expected @@ -3,5 +3,6 @@ R^128 exact orthogonal oracle: PASS invalid contractions rejected by the compiler: PASS finite presheaf restriction laws: PASS provenance-aware named fact lookup: PASS +pair arithmetic construction: PASS quadratic and Hermitian form semantics: PASS complex/projective structural semantics: PASS diff --git a/_/tests/idris2/basic/edric009/run b/_/tests/idris2/basic/edric009/run index eb8b751eb0..50ca5fd1fd 100755 --- a/_/tests/idris2/basic/edric009/run +++ b/_/tests/idris2/basic/edric009/run @@ -11,10 +11,12 @@ cp "$example_dir/MathematicalSpaces.idric" "$fixture_dir/MathematicalSpaces.idri cp "$example_dir/EuclideanGeometry.idric" "$fixture_dir/EuclideanGeometry.idric" cp "$example_dir/TopologyFacts.idric" "$fixture_dir/TopologyFacts.idric" cp "$example_dir/PresheafRestriction.idric" "$fixture_dir/PresheafRestriction.idric" +cp "$example_dir/PairArithmetic.idric" "$fixture_dir/PairArithmetic.idric" cp "$example_dir/NamedFacts.idric" "$fixture_dir/NamedFacts.idric" cp "$example_dir/QuadraticForms.idric" "$fixture_dir/QuadraticForms.idric" cp "$example_dir/ComplexProjective.idric" "$fixture_dir/ComplexProjective.idric" cp "$example_dir/Tests.idric" "$fixture_dir/Tests.idric" +cp "$example_dir/PairArithmeticTests.idric" "$fixture_dir/PairArithmeticTests.idric" cp "$example_dir/FormTests.idric" "$fixture_dir/FormTests.idric" cp "$example_dir/ComplexProjectiveTests.idric" "$fixture_dir/ComplexProjectiveTests.idric" @@ -36,6 +38,18 @@ cp "$example_dir/ComplexProjectiveTests.idric" "$fixture_dir/ComplexProjectiveTe ./build/exec/unified-higher-mathematics + if ! "$idris2" --check PairArithmeticTests.idric >pair-typecheck.log 2>&1; then + cat pair-typecheck.log >&2 + exit 1 + fi + + if ! "$idris2" PairArithmeticTests.idric -o pair-arithmetic >pair-build.log 2>&1; then + cat pair-build.log >&2 + exit 1 + fi + + ./build/exec/pair-arithmetic + if ! "$idris2" --check FormTests.idric >form-typecheck.log 2>&1; then cat form-typecheck.log >&2 exit 1 From 71ad08122a8c4dea1668692ddba100937502710b Mon Sep 17 00:00:00 2001 From: i Date: Wed, 16 Sep 2026 15:50:17 -0400 Subject: [PATCH 77/80] Make signed pair arithmetic definitional --- .../PairArithmetic.idric | 20 ++++++++----------- 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/_/examples/unified-higher-mathematics/PairArithmetic.idric b/_/examples/unified-higher-mathematics/PairArithmetic.idric index b5c5b8b61b..4019de6e11 100644 --- a/_/examples/unified-higher-mathematics/PairArithmetic.idric +++ b/_/examples/unified-higher-mathematics/PairArithmetic.idric @@ -44,26 +44,22 @@ pair_complex_multiply , add (multiply a d) (multiply b c) ) -signed_add : ±Number → ±Number → ±Number -signed_add left right = left + right - -signed_subtract : ±Number → ±Number → ±Number -signed_subtract left right = left - right - -signed_multiply : ±Number → ±Number → ±Number -signed_multiply left right = left * right - +-- The signed exact specialization is written directly so closed acceptance +-- facts reduce definitionally across the module boundary. It is the same pair +-- construction above with the present signed-number operations; it remains a +-- Gaussian-integer oracle rather than a definition of mathematical C. public export signed_pair_add : (±Number, ±Number) → (±Number, ±Number) → (±Number, ±Number) -signed_pair_add = pair_add signed_add +signed_pair_add (first, second) (third, fourth) = + (first + third, second + fourth) public export signed_pair_complex_multiply : (±Number, ±Number) → (±Number, ±Number) → (±Number, ±Number) -signed_pair_complex_multiply = - pair_complex_multiply signed_add signed_subtract signed_multiply +signed_pair_complex_multiply (a, b) (c, d) = + (a * c - b * d, a * d + b * c) From 67b3d29a4212f1e4b0d707d6c0bdd642c917158d Mon Sep 17 00:00:00 2001 From: i Date: Wed, 16 Sep 2026 15:52:39 -0400 Subject: [PATCH 78/80] Connect exact complex fixture to pair arithmetic --- .../ComplexPairAgreement.idric | 50 +++++++++++++++++++ .../ComplexPairAgreementTests.idric | 30 +++++++++++ _/tests/idris2/basic/edric009/expected | 1 + _/tests/idris2/basic/edric009/run | 14 ++++++ 4 files changed, 95 insertions(+) create mode 100644 _/examples/unified-higher-mathematics/ComplexPairAgreement.idric create mode 100644 _/examples/unified-higher-mathematics/ComplexPairAgreementTests.idric diff --git a/_/examples/unified-higher-mathematics/ComplexPairAgreement.idric b/_/examples/unified-higher-mathematics/ComplexPairAgreement.idric new file mode 100644 index 0000000000..7f29b365cc --- /dev/null +++ b/_/examples/unified-higher-mathematics/ComplexPairAgreement.idric @@ -0,0 +1,50 @@ +module ComplexPairAgreement + +import MathematicalSpaces +import PairArithmetic +import QuadraticForms + +%unbound_implicits off + +-- ExactComplex remains the existing Gaussian-integral acceptance fixture. +-- These conversions only expose its two signed coordinates as the pair +-- construction used by PairArithmetic; they do not redefine mathematical C. +public export +exact_complex_as_pair : ExactComplex → (±Number, ±Number) +exact_complex_as_pair (Complex real imaginary) = (real, imaginary) + +public export +pair_as_exact_complex : (±Number, ±Number) → ExactComplex +pair_as_exact_complex (real, imaginary) = Complex real imaginary + +public export +exact_complex_pair_round_trip : + (value : ExactComplex) → + pair_as_exact_complex (exact_complex_as_pair value) = value +exact_complex_pair_round_trip (Complex real imaginary) = Refl + +public export +pair_exact_complex_round_trip : + (value : (±Number, ±Number)) → + exact_complex_as_pair (pair_as_exact_complex value) = value +pair_exact_complex_round_trip (real, imaginary) = Refl + +public export +exact_complex_addition_agrees : + (left : ExactComplex) → + (right : ExactComplex) → + exact_complex_as_pair (complex_add left right) + = signed_pair_add + (exact_complex_as_pair left) + (exact_complex_as_pair right) +exact_complex_addition_agrees (Complex a b) (Complex c d) = Refl + +public export +exact_complex_multiplication_agrees : + (left : ExactComplex) → + (right : ExactComplex) → + exact_complex_as_pair (complex_multiply left right) + = signed_pair_complex_multiply + (exact_complex_as_pair left) + (exact_complex_as_pair right) +exact_complex_multiplication_agrees (Complex a b) (Complex c d) = Refl diff --git a/_/examples/unified-higher-mathematics/ComplexPairAgreementTests.idric b/_/examples/unified-higher-mathematics/ComplexPairAgreementTests.idric new file mode 100644 index 0000000000..2ed5ab9241 --- /dev/null +++ b/_/examples/unified-higher-mathematics/ComplexPairAgreementTests.idric @@ -0,0 +1,30 @@ +module ComplexPairAgreementTests + +import MathematicalSpaces +import PairArithmetic +import QuadraticForms +import ComplexPairAgreement + +%unbound_implicits off + +complex_pair_round_trip_test : + pair_as_exact_complex (exact_complex_as_pair (Complex 2 3)) = Complex 2 3 +complex_pair_round_trip_test = Refl + +complex_pair_addition_test : + exact_complex_as_pair (complex_add (Complex 2 3) (Complex 5 (-1))) = (7, 2) +complex_pair_addition_test = Refl + +complex_pair_multiplication_test : + exact_complex_as_pair (complex_multiply (Complex 2 3) (Complex 5 (-1))) + = (13, 13) +complex_pair_multiplication_test = Refl + +complex_pair_multiplication_agreement_test : + exact_complex_as_pair (complex_multiply (Complex 2 3) (Complex 5 (-1))) + = signed_pair_complex_multiply (2, 3) (5, (-1)) +complex_pair_multiplication_agreement_test = + exact_complex_multiplication_agrees (Complex 2 3) (Complex 5 (-1)) + +main : IO () +main = putStrLn "exact complex pair agreement: PASS" diff --git a/_/tests/idris2/basic/edric009/expected b/_/tests/idris2/basic/edric009/expected index 0f2f2c695e..5c2e78738d 100644 --- a/_/tests/idris2/basic/edric009/expected +++ b/_/tests/idris2/basic/edric009/expected @@ -4,5 +4,6 @@ invalid contractions rejected by the compiler: PASS finite presheaf restriction laws: PASS provenance-aware named fact lookup: PASS pair arithmetic construction: PASS +exact complex pair agreement: PASS quadratic and Hermitian form semantics: PASS complex/projective structural semantics: PASS diff --git a/_/tests/idris2/basic/edric009/run b/_/tests/idris2/basic/edric009/run index 50ca5fd1fd..6310669848 100755 --- a/_/tests/idris2/basic/edric009/run +++ b/_/tests/idris2/basic/edric009/run @@ -14,9 +14,11 @@ cp "$example_dir/PresheafRestriction.idric" "$fixture_dir/PresheafRestriction.id cp "$example_dir/PairArithmetic.idric" "$fixture_dir/PairArithmetic.idric" cp "$example_dir/NamedFacts.idric" "$fixture_dir/NamedFacts.idric" cp "$example_dir/QuadraticForms.idric" "$fixture_dir/QuadraticForms.idric" +cp "$example_dir/ComplexPairAgreement.idric" "$fixture_dir/ComplexPairAgreement.idric" cp "$example_dir/ComplexProjective.idric" "$fixture_dir/ComplexProjective.idric" cp "$example_dir/Tests.idric" "$fixture_dir/Tests.idric" cp "$example_dir/PairArithmeticTests.idric" "$fixture_dir/PairArithmeticTests.idric" +cp "$example_dir/ComplexPairAgreementTests.idric" "$fixture_dir/ComplexPairAgreementTests.idric" cp "$example_dir/FormTests.idric" "$fixture_dir/FormTests.idric" cp "$example_dir/ComplexProjectiveTests.idric" "$fixture_dir/ComplexProjectiveTests.idric" @@ -50,6 +52,18 @@ cp "$example_dir/ComplexProjectiveTests.idric" "$fixture_dir/ComplexProjectiveTe ./build/exec/pair-arithmetic + if ! "$idris2" --check ComplexPairAgreementTests.idric >complex-pair-typecheck.log 2>&1; then + cat complex-pair-typecheck.log >&2 + exit 1 + fi + + if ! "$idris2" ComplexPairAgreementTests.idric -o complex-pair-agreement >complex-pair-build.log 2>&1; then + cat complex-pair-build.log >&2 + exit 1 + fi + + ./build/exec/complex-pair-agreement + if ! "$idris2" --check FormTests.idric >form-typecheck.log 2>&1; then cat form-typecheck.log >&2 exit 1 From 60972d1e20885a4fedf24f074822600c694c0810 Mon Sep 17 00:00:00 2001 From: i Date: Thu, 17 Sep 2026 10:05:23 -0400 Subject: [PATCH 79/80] =?UTF-8?q?Add=20Edri=C3=A7=20memory-tiering=20lower?= =?UTF-8?q?ing=20note?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- EDRIC_MEMORY_TIERING.md | 156 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 156 insertions(+) create mode 100644 EDRIC_MEMORY_TIERING.md diff --git a/EDRIC_MEMORY_TIERING.md b/EDRIC_MEMORY_TIERING.md new file mode 100644 index 0000000000..1e034eab22 --- /dev/null +++ b/EDRIC_MEMORY_TIERING.md @@ -0,0 +1,156 @@ +# Edriç memory-tiering lowering note + +Status: design note. This is not a claim that every phrase below is accepted by the current parser. + +Memory management is a useful forcing example for the intended Edriç boundary because the semantic policy is much easier to state than any one Linux, Android, DEX, C, assembly, or kernel implementation. + +## Start with the policy + +A top-level description should be able to say something close to: + +```idric +when memory becomes scarce + compress cold memory quickly + +when the machine is idle + recompress older cold memory more densely + only when restore remains fast + +when memory remains scarce + move sufficiently cold memory to internal storage + within write budget + +when an application becomes active + restore its likely working memory early + +kill cached application only when cheaper tiers are insufficient +``` + +The exact grammar is open. The important point is that `zram`, `lmkd`, page tables, sysfs files, ioctls, Binder calls, DEX opcodes, and ARM instructions are implementation details below the policy. + +The concrete Android experiment lives in . + +## Lower gradually, and not necessarily uniformly + +Lowering does not need to be one fixed staircase for every action. Different phrases can descend through different mechanisms: + +```text +Edriç policy + | + +-> Android framework action + | -> checked Android/runtime operations + | -> DEX + | + +-> Linux userspace action + | -> syscall / ioctl / sysfs operation + | -> native machine code + | + +-> kernel-side action + | -> checked kernel primitive + | -> target-specific native code + | + +-> GPU experiment + -> typed compute operation + -> GPU target language / machine path +``` + +This is intentionally jagged. `prefetch cached process` might be framework-facing and naturally lower through Android APIs or DEX. Manipulating zram or a kernel page-reclaim primitive ultimately crosses a native Linux/kernel boundary. One source policy should not be forced through one universal implementation language merely to make the compiler pipeline look uniform. + +## C is optional machinery, not the meaning + +C is useful because operating-system APIs, kernels, vendor headers, and toolchains expose many C-shaped boundaries. That makes C a convenient implementation or diagnostic form. It does not make C the semantic intermediate language. + +Possible lower forms include: + +- direct Thumb-2 / AArch32 machine code; +- AArch64, x86-64, RISC-V, or other direct machine-code backends; +- DEX for Android runtime/framework-facing work; +- WebAssembly where its execution model fits; +- GPU/shader or compute targets; +- C as disposable generated source where that remains the simplest boundary; +- another native systems language, including D, when its runtime and ABI requirements fit the target; +- a future Idriç-owned portable machine IR. + +No one of these should become the ontology of the source language. + +## A portable machine IR is plausible + +A future cross-processor IR can sit below semantic Idriç/Edriç operations and above target encodings. It should describe machine-relevant meaning without pretending all processors are identical. + +Useful explicit concepts would include: + +- values and exact widths; +- addresses and address spaces; +- loads, stores, alignment, and atomic ordering; +- branches and calls; +- stack/frame requirements where relevant; +- system-call or foreign-call boundaries; +- traps/errors; +- vector/SIMD operations where the semantic operation really permits them; +- target constraints and required capabilities. + +Then target lowering decides registers, instruction selection, calling convention, relocations, object format, and processor-specific details. + +This would be a portable *machine* representation, not a replacement for the higher semantic IR. It must remain possible to bypass it when a target such as DEX or a GPU has a substantially different execution model. + +## DEX is a real target, but not a Linux-kernel instruction set + +DEX is appropriate for code that belongs in Android's managed/runtime layer. Edriç can therefore lower an Android-side controller, service, policy process, or framework client directly to DEX. + +DEX cannot directly execute as Linux kernel code. Kernel zram, page reclaim, storage drivers, and similar mechanisms still require code accepted by the kernel/native architecture. The source program can nevertheless span both sides by preserving the semantic action above the boundary and lowering each component to the target it actually runs on. + +For example: + +```text +when cached application becomes active + -> Android process-state observation/controller -> DEX + -> request prefetch through typed boundary + -> native userspace or kernel mechanism -> AArch32/AArch64/etc. +``` + +The implementation boundary should be visible and typed rather than hidden behind a pretend single-target compiler. + +## “English-major C” is a useful intermediate presentation + +A human-readable low-level form can become more explicit without immediately becoming punctuation-heavy C. For example: + +```idric +cold_pages ← pages idle longer than idle_threshold + +for each page in cold_pages + if denser compression saves enough memory + and restore latency remains below interactive budget + then + recompress page using secondary compressor +``` + +One level lower might expose page numbers, byte counts, queues, file descriptors, Binder handles, or sysfs paths while still using names and role words rather than positional argument piles. + +Only the final lowering needs to care whether the selected implementation is DEX bytecode, a syscall sequence, C-shaped ABI calls, or direct machine instructions. + +## ComputerScience chooses; Edriç preserves intent + +`walnut-burgundy/computer-science` should eventually choose among implementation variants from target facts and measurements: + +- which compressors exist on this kernel; +- CPU/GPU throughput and energy; +- decompression tail latency; +- memory pressure and likely reuse time; +- internal-storage latency and write budget; +- available Android/kernel interfaces; +- actual target ABI and instruction set. + +Edriç should preserve the semantic request and the constraints needed to make that choice. The compiler should not silently encode one historical operating-system convention such as “all systems work goes through C.” + +## Acceptance boundary + +Keep separate evidence for: + +1. source phrase is parsed/checked; +2. checked semantic operation is preserved in IR; +3. selected lower form is generated; +4. target artifact verifies/loads; +5. code executes through that target on the claimed runtime/device; +6. memory-policy behavior actually improves the measured app-switch workload. + +A DEX artifact does not prove the kernel mechanism. A native helper does not prove the DEX controller. An emulator does not prove the physical low-RAM phone. From 5b96e05d1ea4fb8c2c17ec9dd84a7f7510b42bdd Mon Sep 17 00:00:00 2001 From: i Date: Thu, 17 Sep 2026 12:50:14 -0400 Subject: [PATCH 80/80] =?UTF-8?q?Fix=20Idri=C3=A7=20style=20check=20base?= =?UTF-8?q?=20selection?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/ci_idric_style.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/ci_idric_style.yml b/.github/workflows/ci_idric_style.yml index 77cdbaa827..a406ee3cd9 100644 --- a/.github/workflows/ci_idric_style.yml +++ b/.github/workflows/ci_idric_style.yml @@ -16,3 +16,5 @@ jobs: fetch-depth: 0 - name: Check newly added Idriç source uses: isomorphisms/ai-ci/idric-style@d76e865c3742c51308ddf211ee6f5b724f4104de + with: + base: ${{ github.event_name == 'pull_request' && 'HEAD^1' || github.event.before }}