diff --git a/.github/workflows/ci-edric-types.yml b/.github/workflows/ci-edric-types.yml new file mode 100644 index 00000000000..bc180f5e69d --- /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 diff --git a/.github/workflows/ci-source-layout.yml b/.github/workflows/ci-source-layout.yml index a373e3f1df1..75395902138 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/.github/workflows/ci_idric_style.yml b/.github/workflows/ci_idric_style.yml new file mode 100644 index 00000000000..a406ee3cd9c --- /dev/null +++ b/.github/workflows/ci_idric_style.yml @@ -0,0 +1,20 @@ +name: Idriç source-style drift check + +on: + push: + pull_request: + +permissions: + contents: read + +jobs: + style: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 + with: + 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 }} diff --git a/AGENTS.md b/AGENTS.md new file mode 100644 index 00000000000..a217f3be156 --- /dev/null +++ b/AGENTS.md @@ -0,0 +1,37 @@ +# Idriç agent instructions + +Before writing or reviewing Idriç-facing source, read: + +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 + +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`. + +The repository contains a large inherited Idris codebase. Its existence is not +permission to reproduce Idris/Haskell style in new Idriç work. + +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. diff --git a/ANF_READABLE_NAMES.md b/ANF_READABLE_NAMES.md new file mode 100644 index 00000000000..bb9815c5371 --- /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/COMPLEX-PROJECTIVE.md b/COMPLEX-PROJECTIVE.md new file mode 100644 index 00000000000..d937eb8fea7 --- /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/Compiler/ANF.idr b/Compiler/ANF.idr index e5b25a3d750..6febcf2b92d 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 66e271cf785..6a6c3d7d097 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/IdricOneStep.idr b/Compiler/IdricOneStep.idr new file mode 100644 index 00000000000..80d6c7726f2 --- /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 diff --git a/Compiler/RefC/RefC.idr b/Compiler/RefC/RefC.idr index e06c2bc5598..e2511de3809 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 0f9f7cdef71..9765edf7880 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 c11964d8ad1..37c682efc40 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 @@ -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 diff --git a/EDRIC_MEMORY_TIERING.md b/EDRIC_MEMORY_TIERING.md new file mode 100644 index 00000000000..1e034eab228 --- /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. diff --git a/Idris/CommandLine.idr b/Idris/CommandLine.idr index 53dbbb2a4b5..3248bc3dee3 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 5f3d290312a..cb373f0617f 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 + 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 - IApp fc (IApp fc (IVar 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 - $ ILam 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 (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 (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 IApp fc (IApp fc (IVar 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 IApp fc (IVar 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 $ IVar fc x - True => pure $ IVar 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) - = IPi 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 IPi 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 $ IPi 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 $ ILam 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 $ ILam 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) $ - ICase fc [] (IVar 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 $ ILam 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 $ ILam 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 $ ILam 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) $ - ICase fc [] (IVar 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 $ ILet 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 $ ICase 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 $ ICase 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 $ ILocal 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 $ IUpdate 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 $ IApp 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 $ IAutoApp 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 $ IWithApp 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 $ INamedApp 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 $ IDelayed fc r !(desugarB side ps ty) + = pure $ Elaborable_Delayed_Type fc r !(desugarB side ps ty) desugarB side ps (PDelay fc tm) - = pure $ IDelay fc !(desugarB side ps tm) + = pure $ Elaborable_Delay fc !(desugarB side ps tm) desugarB side ps (PForce fc tm) - = pure $ IForce 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 $ IAlternative fc FirstSuccess - [apply (IVar fc (UN $ Basic "===")) [l', r'], - apply (IVar 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 $ ISearch 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 $ IAlternative fc (UniqueDefault (IPrimVal fc (BI x))) - [IPrimVal fc (BI x), - IPrimVal 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 $ IApp vfc (IVar vfc fi) (IPrimVal 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 $ IPrimVal fc (Ch x) + pure $ Elaborable_Primitive_Value fc (Ch x) Just f => let vfc = virtualiseFC fc in - pure $ IApp vfc (IVar vfc f) (IPrimVal 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 $ IPrimVal fc (Db x) + pure $ Elaborable_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 $ 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 = IQuote 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 = IQuoteName 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 = IQuoteDecl 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 $ IUnquote fc !(desugarB side ps tm) + = pure $ Elaborable_Unquote fc !(desugarB side ps tm) desugarB side ps (PRunElab fc tm) - = pure $ IRunElab 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 $ IHole fc holename - desugarB side ps (PType fc) = pure $ IType 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 $ IAs 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 $ IMustUnify 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 (IPrimVal 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 (IPrimVal 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 (IVar (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 (IVar fc mkpairname) [l', r'] - pure $ IAlternative fc (UniqueDefault pval) - [apply (IVar 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 (IVar opFC mkdpairname) [IVar 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 $ IAlternative fc (UniqueDefault pval) - [apply (IVar opFC dpairname) + pure $ Elaborable_Alternative fc (UniqueDefault pval) + [apply (Elaborable_Name opFC dpairname) [Implicit vfc False, - ILam 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 (IVar opFC dpairname) - [ty', ILam 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 (IVar 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 $ IAlternative fc (UniqueDefault (IVar fc (UN $ Basic "MkUnit"))) - [IVar fc (UN $ Basic "Unit"), - IVar 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 $ 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 $ 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 $ IRewrite 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 $ IUnifyLog 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) - = IWithUnambigNames 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 IFieldUpdate + Side -> List Name -> PFieldUpdate -> Core Elaborable_Field_Update desugarUpdate side ps (PSetField p v) - = pure (ISetField p !(desugarB side ps v)) + = pure (Elaborable_Set_Field p !(desugarB side ps v)) desugarUpdate side ps (PSetFieldApp p v) - = pure (ISetFieldApp 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 (IVar nilFC (UN $ Basic "Nil")) + expandList side ps nilFC [] = pure (Elaborable_Name nilFC (UN $ Basic "Nil")) expandList side ps nilFC ((consFC, x) :: xs) - = pure $ apply (IVar 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 (IVar nilFC (UN $ Basic "Lin")) + expandSnocList side ps nilFC [<] = pure (Elaborable_Name nilFC (UN $ Basic "Lin")) expandSnocList side ps nilFC (xs :< (consFC, x)) - = pure $ apply (IVar 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 - IApp fc (IVar 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 - [] => IPrimVal fc (Str "") + [] => Elaborable_Primitive_Value fc (Str "") (_ :: _) => let vfc = virtualiseFC fc in - IApp vfc - (INamedApp vfc - (IVar vfc (NS preludeNS $ UN $ Basic "concat")) + Elaborable_Apply vfc + (Elaborable_Named_Apply vfc + (Elaborable_Name vfc (NS preludeNS $ UN $ Basic "concat")) (UN $ Basic "t") - (IVar 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 $ IPrimVal 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 [] - = IVar EmptyFC nilName + = Elaborable_Name EmptyFC nilName strInterpolate (x :: xs) = let xFC = virtualiseFC (getFC x) in - apply (IVar xFC consName) - [ IApp xFC (IVar 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' - $ ILam 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' - $ ILam EmptyFC top Explicit (Just (MN "_" 0)) + $ Elaborable_Lambda EmptyFC top Explicit (Just (MN "_" 0)) ty' - (ICase fc [] (IVar 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 = ILet 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 $ - ICase 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 $ ILocal 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 $ IRewrite 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 (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 (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' - _ => ILocal 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 IField) + 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' => - IClaim (MkFCVal claim.fc $ MkIClaimData 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 $ IDef 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 $ IDef 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 $ IDef fc nm [ImpossibleClause fc lhs] + = pure $ Elaborable_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 [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 [IParameters 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 [IPragma 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 [IPragma 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 IField) <- 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 [IRecord 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 => [IFail 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 [INamespace 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 [ITransform 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 [IRunElabDecl 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 [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 [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 [IPragma fc [] (\nest, env => setUnboundImplicits a)] + pure [Elaborable_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 [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 [IPragma 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 [IBuiltin 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 e8f5b0e44af..9b24408126e 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) + = 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 - = IPi 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, INamedApp fc (IVar fc n) constructorBindName (IVar 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 - (IDef 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 (IDef _ n _ :: ds) + dropGot ms (Elaborable_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 (Elaborable_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)) + = 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 - (IBindHere 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 (IVar EmptyFC impName) - (map (\(x, _) => (x, IBindVar 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 (IVar vfc con) $ map (const (ISearch 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 = IDef 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 (INamedApp 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 (IAutoApp (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 - = ILam 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 (IApp EmptyFC tm (IVar EmptyFC x)) xs + = applyTo (Elaborable_Apply EmptyFC tm (Elaborable_Name EmptyFC x)) xs applyTo tm ((x, c, AutoImplicit) :: xs) - = applyTo (INamedApp EmptyFC tm x (IVar EmptyFC x)) xs + = applyTo (Elaborable_Named_Apply EmptyFC tm x (Elaborable_Name EmptyFC x)) xs applyTo tm ((x, c, Implicit) :: xs) - = applyTo (INamedApp EmptyFC tm x (IVar EmptyFC x)) xs + = applyTo (Elaborable_Named_Apply EmptyFC tm x (Elaborable_Name EmptyFC x)) xs applyTo tm ((x, c, DefImplicit _) :: xs) - = applyTo (INamedApp EmptyFC tm x (IVar 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 (IVar EmptyFC n) argns) - (map (\n => (n, IVar 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, IVar 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 - = IPi 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 - = IPi 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 (IVar vfc n) - (map (\x => (x, IBindVar 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 - IClaim $ MkFCVal vfc $ MkIClaimData 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 (IVar fc n) + updateApp ns (Elaborable_Name fc n) = do n' <- findMethName ns fc n - pure (IVar fc n') - updateApp ns (IApp fc f arg) + pure (Elaborable_Name fc n') + updateApp ns (Elaborable_Apply fc f arg) = do f' <- updateApp ns f - pure (IApp fc f' arg) - updateApp ns (IWithApp fc f arg) + pure (Elaborable_Apply fc f' arg) + updateApp ns (Elaborable_With_Apply fc f arg) = do f' <- updateApp ns f - pure (IWithApp fc f' arg) - updateApp ns (IAutoApp fc f arg) + pure (Elaborable_With_Apply fc f' arg) + updateApp ns (Elaborable_Automatic_Apply fc f arg) = do f' <- updateApp ns f - pure (IAutoApp fc f' arg) - updateApp ns (INamedApp 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 (INamedApp 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 (IDef 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 (IDef 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 = INamedApp vfc (IVar vfc meth.name.val) + let lhs = Elaborable_Named_Apply vfc (Elaborable_Name vfc meth.name.val) constructorBindName - (IVar vfc iname) + (Elaborable_Name vfc iname) let Just mname = lookup (dropNS meth.nameVal) ns | Nothing => pure () - let rhs = IVar vfc mname + let rhs = Elaborable_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)) + (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 6436ac5727a..8d16970e806 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 (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 IPi 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 (IBindHere fc m ty) = IBindHere 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 (IClaim (MkWithData _ $ MkIClaimData 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 (IData _ _ _ (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 [] = IType fc +mkDataTy fc [] = Elaborable_Type_Universe fc mkDataTy fc ((n, (_, ty)) :: ps) - = IPi 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 - = IPi 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 (IVar vfc n) (map (IVar 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 $ IData 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, IBindHere (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, IBindHere (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 (IPi 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 IPi 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 = IPi 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 (IVar vfc iname) (map (IVar 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 = IClaim (MkFCVal vfc $ MkIClaimData 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 (IVar vfc cname) (map (IBindVar EmptyFC) bindNames) + let conapp = apply (Elaborable_Name vfc cname) (map (Elaborable_Bind_Name EmptyFC) bindNames) - let lhs = INamedApp vfc - (IVar cn.fc cn.val) -- See #3409 + let lhs = Elaborable_Named_Apply vfc + (Elaborable_Name cn.fc cn.val) -- See #3409 constructorBindName conapp - let rhs = IVar 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 = IDef 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 - = IPi (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, INamedApp vfc (IVar vfc n) constructorBindName (IVar 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 (IVar fc iname) (map (IVar 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 = IClaim (MkFCVal fc $ MkIClaimData 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 (IVar fc cname) constraints) + let conapp = apply (impsBind (Elaborable_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 (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 (IAutoApp fc fn (IBindVar 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 (IDef 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 (IVar vdfc iname) (map (IVar 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 (IVar 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 = IClaim $ MkFCVal vdfc - $ MkIClaimData 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 (IDef 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 - = IPi (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 (INamedApp vdfc tm n (IBindVar 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 (IVar fc n') - = do if n /= n' then pure (IVar 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 (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 (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/ProcessIdr.idr b/Idris/ProcessIdr.idr index 8b8596bc8b4..91a6f02b86f 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 @@ -41,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 @@ -275,6 +294,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 @@ -385,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/Idris/REPL.idr b/Idris/REPL.idr index 84c00483b05..510db5266c4 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) (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 [ IClaim - (MkFCVal replFC $ MkIClaimData top Private [] + pure [ Elaborable_Claim + (MkFCVal replFC $ Make_Elaborable_Claim_Data top Private [] $ Mk [replFC, NoFC it] (Implicit replFC False)) - , IDef replFC it [PatClause replFC (IVar replFC it) (IVar 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 = ILocal 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 = ILocal 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 e26c9da3a75..290d9e8fa41 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_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 (IPi 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 (IPi 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 (ILam 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 (ILet 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 (ICase 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 (ICase 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 (ILocal 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 (ICaseLocal fc _ _ _ sc) = toPTerm p sc - toPTerm p (IUpdate 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 (IApp 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 (IAutoApp 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 (IWithApp 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 (INamedApp 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 (ISearch fc d) = pure (PSearch fc d) - toPTerm p (IAlternative fc _ _) = pure (PImplicit fc) - toPTerm p (IRewrite 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 (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 (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 (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 (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 (IUnquote fc tm) = pure (PUnquote fc !(toPTerm argPrec tm)) - toPTerm p (IRunElab 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 (IUnifyLog 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 (IWithUnambigNames 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} -> - IRawImp -> List (FC, Maybe (Maybe Name), IPTerm) -> + Kinded_Elaborable_Term -> List (FC, Maybe (Maybe Name), IPTerm) -> Core IPTerm - toPTermApp (IApp fc f a) args + toPTermApp (Elaborable_Apply fc f a) args = do a' <- toPTerm argPrec a toPTermApp f ((fc, Nothing, a') :: args) - toPTermApp (INamedApp 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@(IVar 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} -> - IFieldUpdate' KindedName -> Core (PFieldUpdate' KindedName) - toPFieldUpdate (ISetField 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 (ISetFieldApp 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} -> - IField' 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 (IClaim (MkWithData fc $ MkIClaimData 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 (IData fc vis mbtot d) + toPDecl (Elaborable_Data_Declaration fc vis mbtot d) = pure (Just (MkFCVal fc $ PData "" vis mbtot !(toPData d))) - toPDecl (IDef fc n cs) + toPDecl (Elaborable_Definition fc n cs) = pure (Just (MkFCVal fc $ PDef !(traverse toPClause cs))) - toPDecl (IParameters 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 (IRecord 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 (IFail fc msg ds) + toPDecl (Elaborable_Expected_Failure fc msg ds) = do ds' <- traverse toPDecl ds pure (Just (MkFCVal fc $ PFail msg (catMaybes ds'))) - toPDecl (INamespace fc ns ds) + toPDecl (Elaborable_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 (Elaborable_Transformation fc n lhs rhs) = pure (Just (MkFCVal fc $ PTransform (show n) !(toPTerm startPrec lhs) !(toPTerm startPrec rhs))) - toPDecl (IRunElabDecl fc tm) + toPDecl (Elaborable_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 (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) -> IRawImp -> 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} -> - IRawImp -> Core IPTerm + Kinded_Elaborable_Term -> Core IPTerm pterm raw = toCleanPTerm startPrec raw diff --git a/Idris/Syntax.idr b/Idris/Syntax.idr index 49b75928d46..0ac3a8c63c9 100644 --- a/Idris/Syntax.idr +++ b/Idris/Syntax.idr @@ -1098,7 +1098,7 @@ initSyntax initDocStrings [] [] - (IVar EmptyFC (UN $ Basic "main")) + (Elaborable_Name EmptyFC (UN $ Basic "main")) [] where diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000000..0685846f472 --- /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. *** diff --git a/Parser/Source.idr b/Parser/Source.idr index 40534cf52e1..35701a3a0fd 100644 --- a/Parser/Source.idr +++ b/Parser/Source.idr @@ -14,11 +14,42 @@ import System.File %default total +-- 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 + +-- 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 "ℕ") = Ident "Nat" 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" +canonicalize_idric_surface_token (DotSepIdent ns name) + = DotSepIdent (canonicalize_idric_namespace ns) name +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 then IdricSyntax @@ -28,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 diff --git a/STYLE.md b/STYLE.md new file mode 100644 index 00000000000..d5dc8fe94b1 --- /dev/null +++ b/STYLE.md @@ -0,0 +1,211 @@ +# Idriç source style + +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. + +This repository contains two source strata. Files ending in `.idric` show the +Idriç language being designed. Files ending in `.idr` implement the bootstrap +compiler or preserve the inherited 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. + +The canonical intent examples are: + +- [`examples/intent/railway/`](examples/intent/railway/README.md) +- [`examples/intent/http_server/`](examples/intent/http_server/README.md) + +Read them as examples of structure and vocabulary, not as a frozen grammar. + +## Say what the program is doing first + +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. + +Prefer meaningful domain phrases and semantic roles. For example: + +```idric +connection ← accept connection from listener +request ← read request from connection +response ← answer request +write response to connection +``` + +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. + +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. + +Compiler directives are mechanism. Maintained `.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. Processing an `.idric` file must not change +the inherited default for a later `.idr` compatibility file. + +`public export` is for an API that downstream modules must be able to re-export; +it is not a ceremonial prefix for every definition. + +## Names must carry meaning + +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. + +Use `snake_case`, not lowerCamelCase, for ordinary identifiers. + +Avoid names such as `ExternalInvocation`, `InvokeExternal`, abbreviations that +save little space, and generic numbered/positional names when a domain name is +available. + +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. + +## Types should describe the domain + +Do not introduce `Nat` or the older migration spelling `ℕ` in new `.idric` +source. Use `Number` for the maintained whole-number surface. Do not reintroduce +a separate `Cardinality` type merely to split counts away from `Number`. + +Use `Text`, not `String`, for decoded character text in new `.idric` source, and +import `Data.Text` for text operations. These Idriç spellings map to the +inherited string representation and `Data.String` implementation inside the +bootstrap compiler. Ordinary `.idr` compatibility source keeps `String` and the +exact `Data.String` module name unchanged. + +Use a semantic type instead of `Number`, `Text`, a raw integer, `Bits8`, or a +flag when the value has narrower operations or invariants. + +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 such as `SizedList` or +`ListOfLength`. Use `Array` for contiguous indexed storage. Reserve `Vector` for +a mathematical vector-space value. `Vect` survives only at an explicit Idris +compatibility boundary. + +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. + +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. + +Avoid gratuitous currying, bare-application chains, constructor-led program +descriptions, and implementation types in domain vocabulary. + +## Preserve 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. RefC is not a +maintained Idriç backend or fallback. Do not install, invoke, or cite RefC or its +GMP dependency as acceptance for current Idriç work. A direct DEX, Wasm, +machine-code, GPU, or other maintained backend must generate its own target in +its production path and fail closed for unsupported semantics. + +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`. + +## 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. + +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. + +## Explain non-obvious constants + +Special numeric values, encoding boundaries, UTF-8 cutoffs, protocol numbers, +bit masks, opcodes, representation conversions, 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. + +## Acceptance must match the claimed boundary + +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. Do not turn an unsupported +backend, an emulator, a stale branch, or an unrelated fallback into evidence for +the claimed target. + +## 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. diff --git a/TTIMP_READABLE_NAMES.md b/TTIMP_READABLE_NAMES.md new file mode 100644 index 00000000000..16d10e1d64e --- /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, 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` | `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` | `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_elaborable_bound_name` | 4 | +| `isIPrimVal` | `is_primitive_value` | 4 | +| `isIVar` | `is_elaborable_name` | 4 | +| `unIArg` | `elaborable_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 014a0ccd160..8ff94ebb3e6 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 (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, IVar 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 $ IPi 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 $ 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 $ 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 : 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 : 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 (IBindVar 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 $ IBindVar fc (UN (Basic n')) - else pure $ IBindVar 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 (IVar fc nm) - = maybe (IVar fc nm) (IBindVar fc) (lookup nm ns) -doBind ns (IPi 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 - IPi fc rig p mn (doBind ns' aty) (doBind ns' retty) -doBind ns (ILam 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 - 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) + 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 - = IPi (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 - = IPi 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 439f4684440..0fa187afd75 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 $ 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 (IBindHere fc m ty) - = pure $ IBindHere 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 aa553395f7f..eb5459f4769 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 (Elaborable_Bind_Name fc n) exp = do est <- get EST if n `elem` lhsPatVars est - then pure $ IMustUnify fc NonLinearVar orig + then pure $ Elaborable_Must_Unify fc NonLinearVar orig else pure $ orig -expandAmbigName mode nest env orig args (IVar 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 (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 $ Elaborable_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 $ Elaborable_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 [(_, _, 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 [(_, _, IQuoteName fc tm)] (MkPrimNs _ _ _ _ _ (Just dn) _) - = UniqueDefault (IQuoteName fc tm) - uniqType n [(_, _, IQuoteDecl fc tm)] (MkPrimNs _ _ _ _ _ _ (Just ddl)) - = UniqueDefault (IQuoteDecl 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 (IVar fc x) exp RawImp buildAlt f [] = f buildAlt f ((fc', Nothing, a) :: as) - = buildAlt (IApp fc' f a) as + = buildAlt (Elaborable_Apply fc' f a) as buildAlt f ((fc', Just Nothing, a) :: as) - = buildAlt (IAutoApp fc' f a) as + = buildAlt (Elaborable_Automatic_Apply fc' f a) as buildAlt f ((fc', Just (Just i), a) :: as) - = buildAlt (INamedApp 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 (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 Elaborable_Must_Unify fc NotConstructor tm wrapDot prim est (InLHS _) n' _ _ tm = if n' == Resolved (defining est) then tm - else IMustUnify 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 (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 + (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 (IVar 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 (IVar fc x) exp alternativeFirstSuccess : forall n. Vect (S n) RawImp -> RawImp alternativeFirstSuccess [x] = x - alternativeFirstSuccess xs = IAlternative 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 (IApp 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 (INamedApp 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 (IAutoApp 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 (IVar _ n) = couldBeName defs ty n -couldBeFn defs ty (IAlternative {}) = 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 (IVar _ 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 (IVar _ n) = Just n -getName (IApp _ f _) = getName f -getName (INamedApp _ f _ _) = getName f -getName (IAutoApp _ 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 af74ab8e44d..cbc703e451a 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 (Elaborable_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 (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 (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 (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 - IMustUnify {} => tm - IBindVar {} => tm + Elaborable_Must_Unify {} => tm + Elaborable_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 + 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 (IAs _ _ 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 (IApp 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 (IAutoApp 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 (INamedApp 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 (IVar 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 @@ -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 [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 60cbd1612a0..1f594c6a45e 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 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 f4e6873b99a..316672c822a 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) (Elaborable_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 (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) $ - ICaseLocal 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 - -- ICaseLocal 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 (IDef 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 ICaseLocal + -- 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', IAs 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 - IAs loc' nameLoc' side n _ => IAs 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 (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 (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 (IVar 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 (IVar 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 (IVar 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 (IVar 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 (IApp 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 (INamedApp 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 - IVar _ 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 (IVar 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 f4a3f7bdc77..9c7ce32076a 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 (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 93809c89234..9f812877fd5 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 -> 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 (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 (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 (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 (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 (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 (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 bcd0d450916..5f692e638c9 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 (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 (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 (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 (IUnquote fc (IVar 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} -> - IFieldUpdate -> - Core IFieldUpdate - getUnquoteUpdate (ISetField p t) = pure $ ISetField p !(getUnquote t) - getUnquoteUpdate (ISetFieldApp p t) = pure $ ISetFieldApp 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 (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 (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 (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 (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 7f1694d0fe6..cedcd71392f 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, 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 (IVar 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 (IVar 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 - _ => IVar (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 -> IFieldUpdate -> Name -> RawImp -> Rec -> + FC -> Elaborable_Field_Update -> Name -> RawImp -> Rec -> Core Rec -getSides loc (ISetField 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 (ISetFieldApp 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 [IVar (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 IFieldUpdate -> 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 IFieldUpdate -> + 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 IFieldUpdate -> + 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 (IVar vloc (UN $ Basic fldn))) - pure $ ICase 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 IFieldUpdate -> 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 7c901ed2bd2..1188aae843d 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 (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 1ee5becdd63..96a8207ee85 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@(Elaborable_Lambda _ _ Implicit _ _ _) (Bind fc n (Pi _ _ Implicit _) sc) = pure (Just tm) - bindLamTm tm@(ILam _ _ AutoImplicit _ _ _) (Bind fc n (Pi _ _ AutoImplicit _) sc) + bindLamTm tm@(Elaborable_Lambda _ _ AutoImplicit _ _ _) (Bind fc n (Pi _ _ AutoImplicit _) sc) = pure (Just tm) - bindLamTm tm@(ILam _ _ (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 (ILam 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 (ILam 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 (ILam 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@(ILam _ _ Implicit _ _ _) (NBind fc n (Pi _ _ Implicit _) sc) + bindLamNF tm@(Elaborable_Lambda _ _ Implicit _ _ _) (NBind fc n (Pi _ _ Implicit _) sc) = pure tm - bindLamNF tm@(ILam _ _ 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 $ ILam 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 $ ILam 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 $ ILam 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 (IVar 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 (IVar fc n) [] [] [] exp -checkTerm rig elabinfo nest env (IPi 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 (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 (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 (ILam 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 (ILam 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 (ILet 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 (ICase 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 (ILocal 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 (ICaseLocal 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 (IUpdate 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 (IApp 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 (IAutoApp 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 (IWithApp 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 (INamedApp 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 (ISearch 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 (ISearch 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 (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 (Elaborable_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 (Elaborable_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 (Elaborable_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 (Elaborable_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 (Elaborable_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 (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 (IMustUnify 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 (IDelayed 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 (IDelay 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 (IForce 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 (IQuote 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 (IQuoteName 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 (IQuoteDecl 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 (IUnquote 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 (IRunElab 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 (IPrimVal 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 (IType 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 (IHole 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 (IUnifyLog 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 (IWithUnambigNames 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 (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 (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@(ILet {}) 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@(ILocal {}) 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@(IUpdate {}) 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 23ca46626b1..e29c42c391d 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 (Elaborable_Name fc n) exps autos named = buildApp fc n mty exps autos named - go (IAs 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 (IApp fc fn arg) exps autos named + go (Elaborable_Apply fc fn arg) exps autos named = go fn (MkFCVal fc arg :: exps) autos named - go (IWithApp 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 (IAutoApp 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 (INamedApp 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 (IMustUnify 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 (IPrimVal 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 (IType 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 (IAlternative _ (UniqueDefault tm) _) exps autos named + go (Elaborable_Alternative _ (UniqueDefault tm) _) exps autos named = go tm exps autos named go (Implicit fc _) _ _ _ = nextVar fc - go (IBindVar 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 (IVar fc n) + expandNest (Elaborable_Name fc n) = case lookup n (names nest) of - Just (Just n', _, _) => IVar fc n' - _ => IVar 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 (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 (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 2a34be93414..d0a65368237 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 (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 (IVar 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 $ IVar fc n -updateArg allvars var con (IApp fc f a) - = pure $ IApp 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 (IWithApp fc f a) - = pure $ IWithApp 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 (IAutoApp fc f a) - = pure $ IAutoApp 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 (INamedApp fc f n a) - = pure $ INamedApp 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 (IAs 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 (IVar 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 (IVar fc n) (IVar _ n') +findUpdates defs (Elaborable_Name fc n) (Elaborable_Name _ n') = case !(lookupTyExact n' (gamma defs)) of - Just _ => recordUpdate fc n (IVar 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, 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, 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 (IAutoApp _ f a) (IAutoApp _ 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 (IAutoApp _ f a) f' +findUpdates defs (Elaborable_Automatic_Apply _ f a) f' = findUpdates defs f f' -findUpdates defs f (IAutoApp _ f' a) +findUpdates defs f (Elaborable_Automatic_Apply _ f' a) = findUpdates defs f f' -findUpdates defs (INamedApp _ f _ a) (INamedApp _ 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 (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 (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 (IBindHere (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 89e9bd81215..1cb48f9581a 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 = 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 e47fb662fc0..6879dda89aa 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 (Elaborable_Hole fc' rhsn) = do defs <- get Ctxt rhsn' <- uniqueHoleName defs [] rhsn - pure (IHole 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) (ILam _ _ _ _ _ sc) = dropLams k sc + dropLams (S k) (Elaborable_Lambda _ _ _ _ _ sc) = dropLams k sc dropLams _ tm = tm splittableNames : RawImp -> List Name -splittableNames (IApp _ f (IBindVar _ n)) +splittableNames (Elaborable_Apply _ f (Elaborable_Bind_Name _ n)) = splittableNames f ++ [n] -splittableNames (IApp _ f _) +splittableNames (Elaborable_Apply _ f _) = splittableNames f -splittableNames (IWithApp _ f (IBindVar _ n)) +splittableNames (Elaborable_With_Apply _ f (Elaborable_Bind_Name _ n)) = splittableNames f ++ [n] -splittableNames (IWithApp _ f _) +splittableNames (Elaborable_With_Apply _ f _) = splittableNames f -splittableNames (IAutoApp _ f _) +splittableNames (Elaborable_Automatic_Apply _ f _) = splittableNames f -splittableNames (INamedApp _ 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 (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 (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 (IVar loc' n) + updateLHS ups (Elaborable_Name loc' n) = case lookup n ups of - Nothing => IVar loc' n + Nothing => Elaborable_Name loc' n Just tm => fixNames tm - updateLHS ups (IBindVar loc' n) + updateLHS ups (Elaborable_Bind_Name loc' n) = case lookup n ups of - Nothing => IBindVar loc' n + Nothing => Elaborable_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 (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 - (IBindHere 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 (IVar loc n) (pre_env ++ (map (IBindVar loc . UN . Basic) argns))) - (IHole 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 241a782117a..45d02046da7 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_Elaborable_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 = Elaborable_Lambda replFC rig Explicit (Just x) ty (Elaborable_Hole replFC new_hole) pure iintrod - introCon : Name -> Term lhsCtxt -> Core (List IRawImp) + 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 IRawImp) + 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 f854a59af8f..6b689694734 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) + = 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 (IVar 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 (IVar 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 1606f2da613..f77fefa2f92 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 (Elaborable_Primitive_Value (MkFC fname start end) x) <|> do start <- location str <- simpleStr end <- location - pure (IPrimVal (MkFC fname start end) (Str str)) + pure (Elaborable_Primitive_Value (MkFC fname start end) (Str str)) <|> do start <- location exactIdent "Type" end <- location - pure (IType (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 (ISearch (MkFC fname start end) 1000) + pure (Elaborable_Search (MkFC fname start end) 1000) <|> do start <- location x <- name end <- location - pure (IVar (MkFC fname start end) x) + pure (Elaborable_Name (MkFC fname start end) x) <|> do start <- location symbol "$" x <- userName end <- location - pure (IBindVar (MkFC fname start end) x) + pure (Elaborable_Bind_Name (MkFC fname start end) x) <|> do start <- location x <- holeName end <- location - pure (IHole (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 (IApp (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 (INamedApp (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 (IAutoApp (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, IVar (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 (IAs (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 - = IPi 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 - = ILam 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 - ILet 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 (ILocal (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 - ICase 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 (IUpdate (MkFC fname start end) (forget fs) sc) + pure (Elaborable_Record_Update (MkFC fname start end) (forget fs) sc) - field : OriginDesc -> IndentInfo -> Rule IFieldUpdate + field : OriginDesc -> IndentInfo -> Rule Elaborable_Field_Update field fname indents = do path <- sepBy1 (symbol "->") unqualifiedName - upd <- (do symbol "="; pure ISetField) + upd <- (do symbol "="; pure Elaborable_Set_Field) <|> - (do symbol "$="; pure ISetFieldApp) + (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 (IRewrite (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 (IDelayed (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 (IDelayed (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 (IDelay (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 (IForce (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) - = IPi (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 (IVar _ n) = pure n - getFn (IApp _ f a) = getFn f - getFn (IAutoApp _ f a) = getFn f - getFn (INamedApp _ 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 (IApp 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 (IDef (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 IField) +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 IField) + 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 IRecord 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 (ILog 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 $ IBuiltin (boundToFC fname b) t n + pure $ Elaborable_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 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 - IPragma (\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 - IPragma (\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 (IData (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 (INamespace (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 (IClaim (MkFCVal (MkFC fname start end) $ MkIClaimData 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 (IDef loc fn cs :: ds) +collectDefs (Elaborable_Definition loc fn cs :: ds) = let (cs', rest) = spanMap (isClause fn) ds in - IDef 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 (IDef loc fn cs :: ds) (ys, zs) => (y ++ ys, zs) isClause : Name -> ImpDecl -> Maybe (List ImpClause) - isClause n (IDef _ n' cs) + isClause n (Elaborable_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 (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 1b1940f7a06..7b7bf9f8368 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 (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' (IApp fc app (IVar 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' (INamedApp fc app x (IVar 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' (IApp 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' (INamedApp 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' (IAutoApp 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 (IApp fc app (IVar 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 (IApp fc f arg) = getRawArgs (Explicit fc arg :: args) f - getRawArgs args (INamedApp 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 (IAutoApp 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 (IApp 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 (INamedApp fc f n arg) args + = reapply (Elaborable_Named_Apply fc f n arg) args reapply f (Auto fc arg :: args) - = reapply (IAutoApp fc f arg) args + = reapply (Elaborable_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 (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 - IHole 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 - (IDef 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 (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 (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 43c9a9ab63e..435af5b43bd 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 (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 (IVar 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 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 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 - (IBindHere 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 - (IBindHere 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 - (IBindHere 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 c79bbf429d2..5d55d5be7a2 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 (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 (IData 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 (IDef fc fname def) +process eopts nest env (Elaborable_Definition fc fname def) = processDef eopts nest env fc fname def -process eopts nest env (IParameters fc ps decls) +process eopts nest env (Elaborable_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 (Elaborable_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 (Elaborable_Expected_Failure fc msg decls) = processFailing eopts nest env fc msg decls -process eopts nest env (INamespace 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 (ITransform 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 (IRunElabDecl fc tm) +process eopts nest env (Elaborable_Run_Elaborator_Declaration fc tm) = processRunElab eopts nest env fc tm -process eopts nest env (IPragma _ _ act) +process eopts nest env (Elaborable_Pragma _ _ act) = act nest env -process eopts nest env (ILog lvl) +process eopts nest env (Elaborable_Logging lvl) = addLogLevel (uncurry unsafeMkLogLevel <$> lvl) -process eopts nest env (IBuiltin 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 (IClaim dat@(MkWithData fc (MkIClaimData 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 (IClaim (MkWithData fc (MkIClaimData c vis opts ({val := ty'} ty)))) - bindNames (IData 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 (IData 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 b74e3920989..e604c4cff29 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 + (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 - (IBindHere 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, IVar 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 = IVar fc (NS builtinNS (UN $ Basic "Refl")) in - [(map snd mprf, INamedApp 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 (IVar vfc wname) - $ map (\ nm => (Nothing, IVar 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 = IDef 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 <- isIVar hd - args <- traverse (isExplicit >=> bitraverse pure isIBindVar) 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 - IPi 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 - (IBindHere 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 35ca12f8b54..3e33958e9fb 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) (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 [] = IType fc + mkParamTy [] = Elaborable_Type_Universe fc mkParamTy (binder :: ps) - = IPi 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 7f1712befd2..c047795bed5 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 (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 IField -> + 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 : IField -> Name + fname : Elaborable_Field -> Name fname field = field.name.val - farg : IField -> 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 - = IPi 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 (IVar (virtualiseFC fc) tn) (map (\binder => (binder.name.val, IVar 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 (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 (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 [] = 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 [] = 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 = IBindHere 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 (IData 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 (IPi 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 (IType _) = 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 (IData 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) $ - IPi 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 IClaim (MkFCVal bfc (MkIClaimData 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 (IVar bfc con) + = apply (Elaborable_Name bfc con) (replicate done (Implicit bfc True) ++ (if imp == Explicit - then [IBindVar fc' unName] + then [Elaborable_Bind_Name fc' unName] else []) ++ (replicate (countExp sc) (Implicit bfc True))) - let lhs = IApp bfc (IVar bfc rfNameNS) + let lhs = Elaborable_Apply bfc (Elaborable_Name bfc rfNameNS) (if imp == Explicit then lhs_exp - else INamedApp bfc lhs_exp unName - (IBindVar bfc unName)) - let rhs = IVar 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 - (IDef 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 = IVar bfc unNameNS - let rhs = IVar 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 - (IDef 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, IApp bfc (IVar bfc unNameNS) (IVar bfc rname)) :: upds - else (n, IApp bfc (IVar bfc rfNameNS) (IVar 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 85448d5e210..b1a5657f752 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 (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 (IPi 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 - (IBindHere 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 55d8f6ea40a..6ebe7b03d0e 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 (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 (IPi 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 (ILam 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 (ILet 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 (ICase 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 (ILocal 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 (IUpdate 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 (IApp 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 (INamedApp 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 (IAutoApp 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 (IWithApp 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 (ISearch 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 (IAlternative 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 (IRewrite 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 (IBindHere 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 (IBindVar 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 (IAs 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 (IMustUnify 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 (IDelayed 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 (IDelay 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 (IForce 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 (IQuote 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 (IQuoteName 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 (IQuoteDecl 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 (IUnquote 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 (IPrimVal fc' t') + pure (Elaborable_Primitive_Value fc' t') (UN (Basic "IType"), [fc]) => do fc' <- reify defs !(evalClosure defs fc) - pure (IType 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 (IHole 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 (IWithUnambigNames fc' ns' t') + pure (Elaborable_With_Unambiguous_Names fc' ns' t') _ => cantReify val "TTImp" reify defs val = cantReify val "TTImp" export - Reify IFieldUpdate 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 (ISetField 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 (ISetFieldApp 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 IField 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 (IClaimData 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 (MkIClaimData 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 (IClaim 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 (IData 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 (IDef 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 (IParameters 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 (IRecord 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 (IFail 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 (INamespace 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 (ITransform w' x' y' z') + pure (Elaborable_Transformation w' x' y' z') (UN (Basic "ILog"), [x]) => do x' <- reify defs !(evalClosure defs x) - pure (ILog x') + pure (Elaborable_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 (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 (IPi 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 (ILam 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 (ILet 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 (ICase 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 (ILocal 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 (ICaseLocal 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 (IUpdate 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 (IApp 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 (IAutoApp 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 (INamedApp 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 (IWithApp 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 (ISearch 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 (IAlternative 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 (IRewrite 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 (ICoerced tfc d) = reflect fc defs lhs env d - reflect fc defs lhs env (IBindHere 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 (IBindVar 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 (IAs 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 (IMustUnify 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 (IDelayed 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 (IDelay 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 (IForce 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 (IQuote 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 (IQuoteName 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 (IQuoteDecl 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 (IUnquote tfc (IVar _ t)) + reflect fc defs lhs env (Elaborable_Unquote tfc (Elaborable_Name _ t)) = pure (Ref tfc Bound t) - reflect fc defs lhs env (IUnquote 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 (IRunElab tfc _ t) + reflect fc defs lhs env (Elaborable_Run_Elaborator tfc _ t) = throw (InternalError "Can't reflect a %runElab") - reflect fc defs lhs env (IPrimVal 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 (IType 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 (IHole 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 (IUnifyLog 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 (IWithUnambigNames 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 IFieldUpdate where - reflect fc defs lhs env (ISetField 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 (ISetFieldApp 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 IField 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 (IClaimData Name) where - reflect fc defs lhs env (MkIClaimData 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 (IClaim 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 (IData 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 (IDef 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 (IParameters 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 (IRecord 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 (IFail 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 (INamespace 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 (ITransform 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 (IRunElabDecl 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 (IPragma _ _ x) + reflect fc defs lhs env (Elaborable_Pragma _ _ x) = throw (GenericMsg fc "Can't reflect a pragma") - reflect fc defs lhs env (ILog 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 (IBuiltin {}) + 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 708ad506640..434bd8aa4b8 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 - IRawImp : Type - IRawImp = RawImp' KindedName + Kinded_Elaborable_Term : Type + Kinded_Elaborable_Term = RawImp' KindedName public export data RawImp' : Type -> Type where - IVar : FC -> nm -> RawImp' nm - IPi : 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 - ILam : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> + Elaborable_Lambda : FC -> RigCount -> PiInfo (RawImp' nm) -> Maybe Name -> (argTy : RawImp' nm) -> (lamTy : RawImp' nm) -> RawImp' nm - ILet : FC -> (lhsFC : FC) -> RigCount -> Name -> + Elaborable_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) -> + Elaborable_Case : FC -> List (FnOpt' nm) -> RawImp' nm -> (ty : RawImp' nm) -> List (ImpClause' nm) -> RawImp' nm - ILocal : 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'. - ICaseLocal : FC -> (uname : Name) -> + Elaborable_Case_Local_Definition : FC -> (uname : Name) -> (internalName : Name) -> (args : List Name) -> RawImp' nm -> RawImp' nm - IUpdate : FC -> List (IFieldUpdate' nm) -> RawImp' nm -> RawImp' nm + Elaborable_Record_Update : FC -> List (Elaborable_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 + 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 - 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 + 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 - IBindHere : FC -> BindMode -> RawImp' nm -> RawImp' nm + Elaborable_Bind_Here : FC -> BindMode -> RawImp' nm -> RawImp' nm -- A name which should be implicitly bound - IBindVar : FC -> Name -> RawImp' nm + Elaborable_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 + 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 - IMustUnify : FC -> DotReason -> RawImp' nm -> RawImp' nm + Elaborable_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 + 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 - 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 + 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 - IPrimVal : FC -> (c : Constant) -> RawImp' nm - IType : FC -> RawImp' nm - IHole : FC -> String -> RawImp' nm + Elaborable_Primitive_Value : FC -> (c : Constant) -> RawImp' nm + Elaborable_Type_Universe : FC -> RawImp' nm + Elaborable_Hole : FC -> String -> RawImp' nm - IUnifyLog : 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 - IWithUnambigNames : 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 - IFieldUpdate : Type - IFieldUpdate = IFieldUpdate' Name + Elaborable_Field_Update : Type + Elaborable_Field_Update = Elaborable_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 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 (IVar fc n) = show n - show (IPi 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 (ILam 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 (ILet 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 (ICase _ _ scr scrty alts) + show (Elaborable_Case _ _ scr scrty alts) = "(%case (" ++ show scr ++ " : " ++ show scrty ++ ") " ++ show alts ++ ")" - show (ILocal _ def scope) + show (Elaborable_Local_Definitions _ def scope) = "(%local (" ++ show def ++ ") " ++ show scope ++ ")" - show (ICaseLocal _ uname iname args sc) + show (Elaborable_Case_Local_Definition _ uname iname args sc) = "(%caselocal (" ++ show uname ++ " " ++ show iname ++ " " ++ show args ++ ") " ++ show sc ++ ")" - show (IUpdate _ flds rec) + show (Elaborable_Record_Update _ flds rec) = "(%record " ++ showSep ", " (map show flds) ++ " " ++ show rec ++ ")" - show (IApp fc f a) + show (Elaborable_Apply fc f a) = "(" ++ show f ++ " " ++ show a ++ ")" - show (INamedApp fc f n a) + show (Elaborable_Named_Apply fc f n a) = "(" ++ show f ++ " [" ++ show n ++ " = " ++ show a ++ "])" - show (IAutoApp fc f a) + show (Elaborable_Automatic_Apply fc f a) = "(" ++ show f ++ " [" ++ show a ++ "])" - show (IWithApp fc f a) + show (Elaborable_With_Apply fc f a) = "(" ++ show f ++ " | " ++ show a ++ ")" - show (ISearch fc d) + show (Elaborable_Search fc d) = "%search" - show (IAlternative fc ty alts) + show (Elaborable_Alternative fc ty alts) = "(|" ++ showSep "," (map show alts) ++ "|)" - show (IRewrite _ rule tm) + show (Elaborable_Rewrite _ rule tm) = "(%rewrite (" ++ show rule ++ ") (" ++ show tm ++ "))" - show (ICoerced _ tm) = "(%coerced " ++ show tm ++ ")" + show (Elaborable_Coerced _ tm) = "(%coerced " ++ show tm ++ ")" - show (IBindHere fc b sc) + show (Elaborable_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 (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 (IWithUnambigNames 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 (IFieldUpdate' nm) where - show (ISetField p val) = showSep "->" p ++ " = " ++ show val - show (ISetFieldApp 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 - IField : Type - IField = IField' Name + Elaborable_Field : Type + Elaborable_Field = Elaborable_Field' Name public export - IField' : Type -> Type - IField' 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 (IField' 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 (IField' 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 - IImpClause : Type - IImpClause = 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 IClaimData (nm : Type) where - constructor MkIClaimData + 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 - IClaim : WithFC (IClaimData nm) -> ImpDecl' nm - IData : 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 - IDef : FC -> Name -> List (ImpClause' nm) -> ImpDecl' nm - IParameters : FC -> + Elaborable_Definition : FC -> Name -> List (ImpClause' nm) -> ImpDecl' nm + Elaborable_Parameter_Block : FC -> List1 (ImpParameter' (RawImp' nm)) -> List (ImpDecl' nm) -> ImpDecl' nm - IRecord : FC -> + Elaborable_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 + 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 - ILog : Maybe (List String, Nat) -> ImpDecl' nm - IBuiltin : 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 (IClaim (MkWithData _ $ MkIClaimData c _ opts ty)) + show (Elaborable_Claim (MkWithData _ $ Make_Elaborable_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 (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 (IRecord _ _ _ _ d) = show d.val - show (IFail _ 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 (INamespace _ ns decls) + show (Elaborable_Namespace_Block _ ns decls) = "namespace " ++ show ns ++ showSep "\n" (assert_total $ map show decls) - show (ITransform _ n lhs rhs) + show (Elaborable_Transformation _ n lhs rhs) = "%transform " ++ show n ++ " " ++ show lhs ++ " ==> " ++ show rhs - show (IRunElabDecl _ tm) + show (Elaborable_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 (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 (IBuiltin _ type name) = "%builtin " ++ show type ++ " " ++ show name + show (Elaborable_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 (Elaborable_Apply vfc lhs $ Elaborable_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 : Elaborable_Field_Update' nm -> RawImp' nm +getFieldUpdateTerm (Elaborable_Set_Field _ term) = term +getFieldUpdateTerm (Elaborable_Apply_To_Field _ term) = term export -getFieldUpdatePath : IFieldUpdate' nm -> List String -getFieldUpdatePath (ISetField path _) = path -getFieldUpdatePath (ISetFieldApp 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) -> 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) -> 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 -isIPrimVal : RawImp' nm -> Maybe Constant -isIPrimVal (IPrimVal _ c) = Just c -isIPrimVal _ = Nothing +is_primitive_value : RawImp' nm -> Maybe Constant +is_primitive_value (Elaborable_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 (Elaborable_Apply loc f a) = do f' <- lhsInCurrentNS nest f - pure (IApp loc f' a) -lhsInCurrentNS nest (IAutoApp loc f a) + pure (Elaborable_Apply loc f' a) +lhsInCurrentNS nest (Elaborable_Automatic_Apply loc f a) = do f' <- lhsInCurrentNS nest f - pure (IAutoApp loc f' a) -lhsInCurrentNS nest (INamedApp 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 (INamedApp loc f' n a) -lhsInCurrentNS nest (IWithApp 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 (IWithApp loc f' a) -lhsInCurrentNS nest tm@(IVar loc (NS {})) = pure tm -- leave explicit NS alone -lhsInCurrentNS nest (IVar 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 (IVar 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 (IVar loc n) + Just _ => pure (Elaborable_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 (Elaborable_Dependent_Function_Type fc rig p mn aty retty) + = find_names_to_bind aty ++ find_names_to_bind retty +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 (Elaborable_Apply fc fn av) + = find_names_to_bind fn ++ find_names_to_bind 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 (Elaborable_Named_Apply _ fn _ av) + = find_names_to_bind fn ++ find_names_to_bind 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 (Elaborable_As_Pattern fc _ _ (UN (Basic n)) pat) + = n :: find_names_to_bind pat +find_names_to_bind (Elaborable_As_Pattern fc _ _ n pat) + = find_names_to_bind pat +find_names_to_bind (Elaborable_Must_Unify fc r pat) + = find_names_to_bind pat +find_names_to_bind (Elaborable_Alternative fc u alts) + = concatMap find_names_to_bind alts +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 -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 (Elaborable_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 (Elaborable_Dependent_Function_Type fc rig p mn aty retty) = findImplicits aty ++ findImplicits retty -findImplicits (ILam fc rig p n aty sc) +findImplicits (Elaborable_Lambda fc rig p n aty sc) = findImplicits aty ++ findImplicits sc -findImplicits (IApp fc fn av) +findImplicits (Elaborable_Apply fc fn av) = findImplicits fn ++ findImplicits av -findImplicits (IAutoApp _ fn av) +findImplicits (Elaborable_Automatic_Apply _ fn av) = findImplicits fn ++ findImplicits av -findImplicits (INamedApp _ fn _ av) +findImplicits (Elaborable_Named_Apply _ fn _ av) = findImplicits fn ++ findImplicits av -findImplicits (IWithApp fc fn av) +findImplicits (Elaborable_With_Apply fc fn av) = findImplicits fn ++ findImplicits av -findImplicits (IAs fc _ _ n pat) +findImplicits (Elaborable_As_Pattern fc _ _ n pat) = findImplicits pat -findImplicits (IMustUnify fc r pat) +findImplicits (Elaborable_Must_Unify fc r pat) = findImplicits pat -findImplicits (IAlternative fc u alts) +findImplicits (Elaborable_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 (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 --- IBindVar 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} -> @@ -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 (Elaborable_Apply loc f a) = do f' <- setAs is (Nothing :: es) f - pure $ IApp loc f' a - setAs is es (IAutoApp 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 $ IAutoApp loc f' a - setAs is es (INamedApp 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 $ INamedApp loc f' n a - setAs is es (IWithApp 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 $ IWithApp loc f' a - setAs is es (IVar 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 $ IVar 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 (IVar 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 $ - INamedApp loc' tm nm (IBindVar loc' nm) + Elaborable_Named_Apply loc' tm nm (Elaborable_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)) + 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 $ - INamedApp loc' tm n - (IAs 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 : IField -> 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 (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 (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 (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 (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 (IPragma _ 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 -isIVar : RawImp' nm -> Maybe (FC, nm) -isIVar (IVar fc v) = Just (fc, v) -isIVar _ = Nothing +is_elaborable_name : RawImp' nm -> Maybe (FC, nm) +is_elaborable_name (Elaborable_Name fc v) = Just (fc, v) +is_elaborable_name _ = Nothing export -isIBindVar : RawImp' nm -> Maybe (FC, Name) -isIBindVar (IBindVar fc v) = Just (fc, v) -isIBindVar _ = 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 (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 (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 (IWithUnambigNames x _ _) = x +getFC (Elaborable_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 (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 -IArg : Type -IArg = 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 -unIArg : Arg' nm -> RawImp' nm -unIArg (Explicit _ t) = t -unIArg (Auto _ t) = t -unIArg (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 (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 (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 (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 (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 (IApp (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 = IApp (getFC f) f x - app f (Just nm) x = INamedApp (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 (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 (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 8baaf30baf3..8fd9bca1390 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 (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 (IWithUnambigNames fc ns t) - = IWithUnambigNames 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 IClaimData where - map f (MkIClaimData rig vis opts ty) - = MkIClaimData 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 (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 (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 IFieldUpdate' where - map f (ISetField path t) = ISetField path (map f t) - map f (ISetFieldApp path t) = ISetFieldApp 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 439fef12caa..ec08c80d899 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 (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 (ILam 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 (ILet 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 (ICase 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 (ILocal fc xs sc) + toBuf (Elaborable_Local_Definitions fc xs sc) = do tag 5; toBuf fc; toBuf xs; toBuf sc - toBuf (ICaseLocal fc _ _ _ sc) + toBuf (Elaborable_Case_Local_Definition fc _ _ _ sc) = toBuf sc - toBuf (IUpdate fc fs rec) + toBuf (Elaborable_Record_Update fc fs rec) = do tag 6; toBuf fc; toBuf fs; toBuf rec - toBuf (IApp fc fn arg) + toBuf (Elaborable_Apply fc fn arg) = do tag 7; toBuf fc; toBuf fn; toBuf arg - toBuf (INamedApp fc fn y arg) + toBuf (Elaborable_Named_Apply fc fn y arg) = do tag 8; toBuf fc; toBuf fn; toBuf y; toBuf arg - toBuf (IWithApp fc fn arg) + toBuf (Elaborable_With_Apply fc fn arg) = do tag 9; toBuf fc; toBuf fn; toBuf arg - toBuf (ISearch fc depth) + toBuf (Elaborable_Search fc depth) = do tag 10; toBuf fc; toBuf depth - toBuf (IAlternative fc y xs) + toBuf (Elaborable_Alternative fc y xs) = do tag 11; toBuf fc; toBuf y; toBuf xs - toBuf (IRewrite fc x y) + toBuf (Elaborable_Rewrite fc x y) = do tag 12; toBuf fc; toBuf x; toBuf y - toBuf (ICoerced fc y) + toBuf (Elaborable_Coerced fc y) = do tag 13; toBuf fc; toBuf y - toBuf (IBindHere fc m y) + toBuf (Elaborable_Bind_Here fc m y) = do tag 14; toBuf fc; toBuf m; toBuf y - toBuf (IBindVar fc y) + toBuf (Elaborable_Bind_Name fc y) = do tag 15; toBuf fc; toBuf y - toBuf (IAs 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 (IMustUnify 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 (IDelayed fc r y) + toBuf (Elaborable_Delayed_Type fc r y) = do tag 18; toBuf fc; toBuf r; toBuf y - toBuf (IDelay fc t) + toBuf (Elaborable_Delay fc t) = do tag 19; toBuf fc; toBuf t - toBuf (IForce fc t) + toBuf (Elaborable_Force fc t) = do tag 20; toBuf fc; toBuf t - toBuf (IQuote fc t) + toBuf (Elaborable_Quote fc t) = do tag 21; toBuf fc; toBuf t - toBuf (IQuoteName fc t) + toBuf (Elaborable_Quote_Name fc t) = do tag 22; toBuf fc; toBuf t - toBuf (IQuoteDecl fc t) + toBuf (Elaborable_Quote_Declarations fc t) = do tag 23; toBuf fc; toBuf t - toBuf (IUnquote fc t) + toBuf (Elaborable_Unquote fc t) = do tag 24; toBuf fc; toBuf t - toBuf (IRunElab fc re t) + toBuf (Elaborable_Run_Elaborator fc re t) = do tag 25; toBuf fc; toBuf re; toBuf t - toBuf (IPrimVal fc y) + toBuf (Elaborable_Primitive_Value fc y) = do tag 26; toBuf fc; toBuf y - toBuf (IType fc) + toBuf (Elaborable_Type_Universe fc) = do tag 27; toBuf fc - toBuf (IHole fc y) + toBuf (Elaborable_Hole fc y) = do tag 28; toBuf fc; toBuf y - toBuf (IUnifyLog 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 (IWithUnambigNames fc ns rhs) + toBuf (Elaborable_With_Unambiguous_Names fc ns rhs) = do tag 30; toBuf fc; toBuf ns; toBuf rhs - toBuf (IAutoApp 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 (IVar fc n) + pure (Elaborable_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 (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 (ILam 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 (ILet 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 (ICase fc opts y ty xs) + pure (Elaborable_Case fc opts y ty xs) 5 => do fc <- fromBuf; xs <- fromBuf; sc <- fromBuf - pure (ILocal fc xs sc) + pure (Elaborable_Local_Definitions fc xs sc) 6 => do fc <- fromBuf; fs <- fromBuf rec <- fromBuf - pure (IUpdate fc fs rec) + pure (Elaborable_Record_Update fc fs rec) 7 => do fc <- fromBuf; fn <- fromBuf arg <- fromBuf - pure (IApp fc fn arg) + pure (Elaborable_Apply fc fn arg) 8 => do fc <- fromBuf; fn <- fromBuf y <- fromBuf; arg <- fromBuf - pure (INamedApp fc fn y arg) + pure (Elaborable_Named_Apply fc fn y arg) 9 => do fc <- fromBuf; fn <- fromBuf arg <- fromBuf - pure (IWithApp fc fn arg) + pure (Elaborable_With_Apply fc fn arg) 10 => do fc <- fromBuf; depth <- fromBuf - pure (ISearch fc depth) + pure (Elaborable_Search fc depth) 11 => do fc <- fromBuf; y <- fromBuf xs <- fromBuf - pure (IAlternative fc y xs) + pure (Elaborable_Alternative fc y xs) 12 => do fc <- fromBuf; x <- fromBuf; y <- fromBuf - pure (IRewrite fc x y) + pure (Elaborable_Rewrite fc x y) 13 => do fc <- fromBuf; y <- fromBuf - pure (ICoerced fc y) + pure (Elaborable_Coerced fc y) 14 => do fc <- fromBuf; m <- fromBuf; y <- fromBuf - pure (IBindHere fc m y) + pure (Elaborable_Bind_Here fc m y) 15 => do fc <- fromBuf; y <- fromBuf - pure (IBindVar fc y) + pure (Elaborable_Bind_Name fc y) 16 => do fc <- fromBuf; nameFC <- fromBuf side <- fromBuf; y <- fromBuf; pattern <- fromBuf - pure (IAs fc nameFC side y pattern) + pure (Elaborable_As_Pattern fc nameFC side y pattern) 17 => do fc <- fromBuf pattern <- fromBuf - pure (IMustUnify fc UnknownDot pattern) + pure (Elaborable_Must_Unify fc UnknownDot pattern) 18 => do fc <- fromBuf; r <- fromBuf y <- fromBuf - pure (IDelayed fc r y) + pure (Elaborable_Delayed_Type fc r y) 19 => do fc <- fromBuf; y <- fromBuf - pure (IDelay fc y) + pure (Elaborable_Delay fc y) 20 => do fc <- fromBuf; y <- fromBuf - pure (IForce fc y) + pure (Elaborable_Force fc y) 21 => do fc <- fromBuf; y <- fromBuf - pure (IQuote fc y) + pure (Elaborable_Quote fc y) 22 => do fc <- fromBuf; y <- fromBuf - pure (IQuoteName fc y) + pure (Elaborable_Quote_Name fc y) 23 => do fc <- fromBuf; y <- fromBuf - pure (IQuoteDecl fc y) + pure (Elaborable_Quote_Declarations fc y) 24 => do fc <- fromBuf; y <- fromBuf - pure (IUnquote fc y) + pure (Elaborable_Unquote fc y) 25 => do fc <- fromBuf; re <- fromBuf; y <- fromBuf - pure (IRunElab fc re y) + pure (Elaborable_Run_Elaborator fc re y) 26 => do fc <- fromBuf; y <- fromBuf - pure (IPrimVal fc y) + pure (Elaborable_Primitive_Value fc y) 27 => do fc <- fromBuf - pure (IType fc) + pure (Elaborable_Type_Universe fc) 28 => do fc <- fromBuf; y <- fromBuf - pure (IHole 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 (IWithUnambigNames fc ns rhs) + pure (Elaborable_With_Unambiguous_Names fc ns rhs) 31 => do fc <- fromBuf; fn <- fromBuf arg <- fromBuf - pure (IAutoApp fc fn arg) + pure (Elaborable_Automatic_Apply fc fn arg) _ => corrupt "RawImp" export - TTC IFieldUpdate where - toBuf (ISetField p val) + TTC Elaborable_Field_Update where + toBuf (Elaborable_Set_Field p val) = do tag 0; toBuf p; toBuf val - toBuf (ISetFieldApp 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 (ISetField p val) + pure (Elaborable_Set_Field p val) 1 => do p <- fromBuf; val <- fromBuf - pure (ISetFieldApp p val) + pure (Elaborable_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 (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 $ MkIClaimData rig vis opts type + pure $ Make_Elaborable_Claim_Data rig vis opts type export TTC ImpDecl where - toBuf (IClaim claim) + toBuf (Elaborable_Claim claim) = do tag 0; toBuf claim - toBuf (IData fc vis mbtot d) + toBuf (Elaborable_Data_Declaration fc vis mbtot d) = do tag 1; toBuf fc; toBuf vis; toBuf mbtot; toBuf d - toBuf (IDef fc n xs) + toBuf (Elaborable_Definition fc n xs) = do tag 2; toBuf fc; toBuf n; toBuf xs - toBuf (IParameters fc vis d) + toBuf (Elaborable_Parameter_Block fc vis d) = do tag 3; toBuf fc; toBuf vis; toBuf d - toBuf (IRecord 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 (INamespace fc xs ds) + toBuf (Elaborable_Namespace_Block fc xs ds) = do tag 5; toBuf fc; toBuf xs; toBuf ds - toBuf (ITransform fc n lhs rhs) + toBuf (Elaborable_Transformation fc n lhs rhs) = do tag 6; toBuf fc; toBuf n; toBuf lhs; toBuf rhs - toBuf (IRunElabDecl fc tm) + toBuf (Elaborable_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 (Elaborable_Pragma _ _ f) = throw (InternalError "Can't write Pragma") + toBuf (Elaborable_Logging n) = do tag 8; toBuf n - toBuf (IBuiltin fc type name) + toBuf (Elaborable_Builtin_Declaration fc type name) = do tag 9; toBuf fc; toBuf type; toBuf name - toBuf (IFail {}) + toBuf (Elaborable_Expected_Failure {}) = pure () fromBuf = case !getTag of 0 => do claimData <- fromBuf - pure (IClaim claimData) + pure (Elaborable_Claim claimData) 1 => do fc <- fromBuf; vis <- fromBuf mbtot <- fromBuf; d <- fromBuf - pure (IData fc vis mbtot d) + pure (Elaborable_Data_Declaration fc vis mbtot d) 2 => do fc <- fromBuf; n <- fromBuf xs <- fromBuf - pure (IDef fc n xs) + pure (Elaborable_Definition fc n xs) 3 => do fc <- fromBuf; vis <- fromBuf d <- fromBuf - pure (IParameters fc vis d) + pure (Elaborable_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 (Elaborable_Record_Declaration fc ns vis mbtot r) 5 => do fc <- fromBuf; xs <- fromBuf ds <- fromBuf - pure (INamespace fc xs ds) + pure (Elaborable_Namespace_Block fc xs ds) 6 => do fc <- fromBuf; n <- fromBuf lhs <- fromBuf; rhs <- fromBuf - pure (ITransform fc n lhs rhs) + pure (Elaborable_Transformation fc n lhs rhs) 7 => do fc <- fromBuf; tm <- fromBuf - pure (IRunElabDecl fc tm) + pure (Elaborable_Run_Elaborator_Declaration fc tm) 8 => do n <- fromBuf - pure (ILog n) + pure (Elaborable_Logging n) 9 => do fc <- fromBuf type <- fromBuf name <- fromBuf - pure (IBuiltin 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 79aca98148b..88b65c3e0f3 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 (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 : IFieldUpdate' nm -> IFieldUpdate' nm - mapIFieldUpdate (ISetField path t) = ISetField path (mapTTImp t) - mapIFieldUpdate (ISetFieldApp path t) = ISetFieldApp 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@(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@(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 (IWithUnambigNames fc xs t) = f $ IWithUnambigNames 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 b5ddeb58096..0e652c4245f 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_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 IImpClause) + 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 IRawImp) + (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 $ ICase fc [] tm (Implicit fc False) pats' + pure $ Just $ Elaborable_Case fc [] tm (Implicit fc False) pats' - dropParams : List (Name, Nat) -> (IRawImp, Glued vars) -> - Core (IRawImp, 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 - (IVar fc n, args) => + (Elaborable_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 (Elaborable_Name fc n) (drop i args), ty) _ => pure (tm, ty) where - apply : IRawImp -> List IArg -> IRawImp + apply : Kinded_Elaborable_Term -> List Kinded_Elaborable_Argument -> Kinded_Elaborable_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 (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 (IRawImp, 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 (IRawImp, 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 (IVar 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 (IVar 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 (IVar 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 _)) => ISearch fc d - _ => IHole 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 (IApp 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 (INamedApp fc fn' x arg', + pure (Elaborable_Named_Apply fc fn' x arg', glueBack defs env sc') - _ => pure (IApp 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 - IVar _ n => + Elaborable_Name _ n => case umode of - NoSugar _ => pure (IAs 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 (IDelayed 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 (IDelay 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 (IForce fc tm', gErased fc) - unelabTy' umode nest env (PrimVal fc c) = pure (IPrimVal 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 (IType 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 IRawImp) + 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) -> - IRawImp -> Term (x :: vars) -> - Core (IRawImp, 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 (ILam 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 (ILet 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 (IPi 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 (ILet 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 IRawImp + 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 IRawImp + 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 IRawImp + 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 IRawImp + Term vars -> Core Kinded_Elaborable_Term unelabNest mode nest env (Meta fc n i args) = do let mkn = nameRoot n ++ showScope args - pure (IHole 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 IRawImp + Term vars -> Core Kinded_Elaborable_Term unelab = unelabNest Full [] diff --git a/TTImp/Utils.idr b/TTImp/Utils.idr index 7fc30f996b7..d8f36361b8a 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) + 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 - 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 + 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 - 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 {} => [] + 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 : IField -> 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 IAlternative. +-- 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 (IVar 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 (IPi 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 (ILam 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 (IApp 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 (INamedApp 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 (IAutoApp 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 (IWithApp 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 (IAs 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 (IAs fc _ _ n pat) +findBindableNames arg env used (Elaborable_As_Pattern fc _ _ n pat) = findBindableNames arg env used pat -findBindableNames arg env used (IMustUnify fc r pat) +findBindableNames arg env used (Elaborable_Must_Unify fc r pat) = findBindableNames arg env used pat -findBindableNames arg env used (IDelayed fc r t) +findBindableNames arg env used (Elaborable_Delayed_Type fc r t) = findBindableNames arg env used t -findBindableNames arg env used (IDelay fc t) +findBindableNames arg env used (Elaborable_Delay fc t) = findBindableNames arg env used t -findBindableNames arg env used (IForce fc t) +findBindableNames arg env used (Elaborable_Force fc t) = findBindableNames arg env used t -findBindableNames arg env used (IQuote fc t) +findBindableNames arg env used (Elaborable_Quote fc t) = findBindableNamesQuot env used t -findBindableNames arg env used (IQuoteDecl fc d) +findBindableNames arg env used (Elaborable_Quote_Declarations fc d) = findBindableNamesQuot env used !(rawImpFromDecl !d) -findBindableNames arg env used (IAlternative fc u alts) +findBindableNames arg env used (Elaborable_Alternative fc u alts) = concatMap (findBindableNames arg env used) alts -findBindableNames arg env used (IUpdate 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 (IPi 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 (ILam 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 (ILet 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 (ICase 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 (ILocal fc xs x) +findBindableNamesQuot env used (Elaborable_Local_Definitions fc xs x) = findBindableNamesQuot env used !(x :: rawImpFromDecl !xs) -findBindableNamesQuot env used (ICaseLocal fc uname internalName args x) +findBindableNamesQuot env used (Elaborable_Case_Local_Definition fc uname internalName args x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (IApp fc x y) +findBindableNamesQuot env used (Elaborable_Apply fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (INamedApp fc x y z) +findBindableNamesQuot env used (Elaborable_Named_Apply fc x y z) = findBindableNamesQuot env used ![x, z] -findBindableNamesQuot env used (IAutoApp fc x y) +findBindableNamesQuot env used (Elaborable_Automatic_Apply fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (IWithApp fc x y) +findBindableNamesQuot env used (Elaborable_With_Apply fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (IRewrite fc x y) +findBindableNamesQuot env used (Elaborable_Rewrite fc x y) = findBindableNamesQuot env used ![x, y] -findBindableNamesQuot env used (ICoerced fc x) +findBindableNamesQuot env used (Elaborable_Coerced fc x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (IBindHere fc x y) +findBindableNamesQuot env used (Elaborable_Bind_Here fc x y) = findBindableNamesQuot env used y -findBindableNamesQuot env used (IUpdate fc xs x) +findBindableNamesQuot env used (Elaborable_Record_Update fc xs x) = findBindableNamesQuot env used !(x :: map getFieldUpdateTerm xs) -findBindableNamesQuot env used (IAs fc nfc x y z) +findBindableNamesQuot env used (Elaborable_As_Pattern fc nfc x y z) = findBindableNamesQuot env used z -findBindableNamesQuot env used (IDelayed fc x y) +findBindableNamesQuot env used (Elaborable_Delayed_Type fc x y) = findBindableNamesQuot env used y -findBindableNamesQuot env used (IDelay fc x) +findBindableNamesQuot env used (Elaborable_Delay fc x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (IForce fc x) +findBindableNamesQuot env used (Elaborable_Force fc x) = findBindableNamesQuot env used x -findBindableNamesQuot env used (IUnquote fc x) +findBindableNamesQuot env used (Elaborable_Unquote fc x) = findBindableNames True env used x -findBindableNamesQuot env used (IWithUnambigNames fc xs x) +findBindableNamesQuot env used (Elaborable_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 (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 (IMustUnify fc x y) +findBindableNamesQuot env used (Elaborable_Must_Unify fc x y) = findBindableNamesQuot env used y -findBindableNamesQuot env used (IUnifyLog 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 (IQuote fc x) = [] -findBindableNamesQuot env used (IQuoteName fc x) = [] -findBindableNamesQuot env used (IQuoteDecl fc xs) = [] -findBindableNamesQuot env used (IRunElab 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 (IVar fc n) +findAllNames env (Elaborable_Name fc n) = if not (n `elem` env) then [n] else [] -findAllNames env (IPi 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 (ILam 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 (IApp fc fn av) +findAllNames env (Elaborable_Apply fc fn av) = findAllNames env fn ++ findAllNames env av -findAllNames env (INamedApp fc fn n av) +findAllNames env (Elaborable_Named_Apply fc fn n av) = findAllNames env fn ++ findAllNames env av -findAllNames env (IAutoApp fc fn av) +findAllNames env (Elaborable_Automatic_Apply fc fn av) = findAllNames env fn ++ findAllNames env av -findAllNames env (IWithApp fc fn av) +findAllNames env (Elaborable_With_Apply fc fn av) = findAllNames env fn ++ findAllNames env av -findAllNames env (IAs fc _ _ n pat) +findAllNames env (Elaborable_As_Pattern fc _ _ n pat) = n :: findAllNames env pat -findAllNames env (IMustUnify fc r pat) +findAllNames env (Elaborable_Must_Unify fc r pat) = findAllNames env pat -findAllNames env (IDelayed fc r t) +findAllNames env (Elaborable_Delayed_Type fc r t) = findAllNames env t -findAllNames env (IDelay fc t) +findAllNames env (Elaborable_Delay fc t) = findAllNames env t -findAllNames env (IForce fc t) +findAllNames env (Elaborable_Force fc t) = findAllNames env t -findAllNames env (IQuote fc t) +findAllNames env (Elaborable_Quote fc t) = findAllNames env t -findAllNames env (IUnquote fc t) +findAllNames env (Elaborable_Unquote fc t) = findAllNames env t -findAllNames env (IAlternative fc u alts) +findAllNames env (Elaborable_Alternative fc u alts) = concatMap (findAllNames env) alts -findAllNames env (IUpdate 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 (IPi fc rig p mn aty retty) +findIBindVars (Elaborable_Dependent_Function_Type fc rig p mn aty retty) = findIBindVars aty ++ findIBindVars retty -findIBindVars (ILam fc rig p mn aty sc) +findIBindVars (Elaborable_Lambda fc rig p mn aty sc) = findIBindVars aty ++ findIBindVars sc -findIBindVars (IApp fc fn av) +findIBindVars (Elaborable_Apply fc fn av) = findIBindVars fn ++ findIBindVars av -findIBindVars (INamedApp fc fn n av) +findIBindVars (Elaborable_Named_Apply fc fn n av) = findIBindVars fn ++ findIBindVars av -findIBindVars (IAutoApp fc fn av) +findIBindVars (Elaborable_Automatic_Apply fc fn av) = findIBindVars fn ++ findIBindVars av -findIBindVars (IWithApp fc fn av) +findIBindVars (Elaborable_With_Apply fc fn av) = findIBindVars fn ++ findIBindVars av -findIBindVars (IBindVar fc v) +findIBindVars (Elaborable_Bind_Name fc v) = [v] -findIBindVars (IDelayed fc r t) +findIBindVars (Elaborable_Delayed_Type fc r t) = findIBindVars t -findIBindVars (IDelay fc t) +findIBindVars (Elaborable_Delay fc t) = findIBindVars t -findIBindVars (IForce fc t) +findIBindVars (Elaborable_Force fc t) = findIBindVars t -findIBindVars (IAlternative fc u alts) +findIBindVars (Elaborable_Alternative fc u alts) = concatMap findIBindVars alts -findIBindVars (IUpdate 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 (IVar fc n) + substNames' False bound ps (Elaborable_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) + _ => 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 - _ => IBindVar fc n - else IBindVar fc n - substNames' bvar bound ps (IPi 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 - IPi 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 (ILam 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 - ILam 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 (ILet 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 - ILet 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 (ICase fc opts y ty xs) - = ICase 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 (ILocal fc xs y) + substNames' bvar bound ps (Elaborable_Local_Definitions fc xs y) = let bound' = definedInBlock emptyNS xs ++ bound in - ILocal 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 (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 (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 (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 (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' (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' (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' (ILam fc r p mn argTy scope) - = ILam 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' (ILet fc lhsFC r n nTy nVal scope) - = ILet 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' (ICase fc opts y ty xs) - = ICase 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' (ILocal fc xs y) - = ILocal 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' (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' (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' (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' (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 (IPi _ _ Explicit _ _ ty) = [] - collectImplicits (IPi _ _ _ (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 = IBindVar fc - ivar False = IVar 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 385333da906..8e2c97657a3 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 (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 (IBindVar to n) tm@(IBindVar from _) + getMatch lhs (Elaborable_Bind_Name to n) tm@(Elaborable_Bind_Name from _) = [(n, tm)] <$ addAlias from to - getMatch lhs (IBindVar _ n) tm = pure [(n, tm)] + getMatch lhs (Elaborable_Bind_Name _ n) tm = pure [(n, tm)] getMatch lhs (Implicit {}) tm = pure [] - getMatch lhs _ (IMustUnify _ UserDotted _) = pure [] + getMatch lhs _ (Elaborable_Must_Unify _ UserDotted _) = pure [] - getMatch lhs (IVar to (NS ns n)) (IVar 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 (IVar to (NS ns n)) (IVar 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 (IVar to n) (IVar 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 (IPi _ c p n arg ret) (IPi 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 (IApp _ f a) (IApp loc f' a') + getMatch lhs (Elaborable_Apply _ f a) (Elaborable_Apply loc f' a') = matchAll lhs [(f, f'), (a, a')] - getMatch lhs (IAutoApp _ f a) (IAutoApp loc f' a') + getMatch lhs (Elaborable_Automatic_Apply _ f a) (Elaborable_Automatic_Apply loc f' a') = matchAll lhs [(f, f'), (a, a')] - getMatch lhs (INamedApp _ f n a) (INamedApp 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 (IWithApp _ f a) (IWithApp 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 (INamedApp fc f n a) f' + getMatch True (Elaborable_Named_Apply fc f n a) f' = matchAll True [(f, f'), (a, a)] - getMatch True (IAutoApp 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 (INamedApp fc f n a) f' + getMatch False (Elaborable_Named_Apply fc f n a) f' = getMatch False f f' - getMatch False (IAutoApp 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 (INamedApp fc f' n a) + getMatch lhs f (Elaborable_Named_Apply fc f' n a) = matchFail fc - getMatch lhs f (IAutoApp 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 (IAlternative _ _ as) (IAlternative fc _ as') + getMatch lhs (Elaborable_Alternative _ _ as) (Elaborable_Alternative fc _ as') = matchAny fc lhs (zip as as') - getMatch lhs (IAs _ _ _ nm@(UN (Basic _)) p) (IAs _ 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, IAs fc emptyFC UseLeft nm' (Implicit fc True)) :: ms) - getMatch lhs (IAs _ _ _ 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 (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 (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 = ISearch ploc 500 in + let arg = Elaborable_Search ploc 500 in if isJust (isLHS mode) - then IAs 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 IAs 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 (IVar 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) (IApp _ f arg) + dropWithArgs (S k) (Elaborable_Apply _ f arg) = do (tm, rest) <- dropWithArgs k f pure (tm, arg :: rest) - dropWithArgs (S k) (IWithApp _ 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 (IWithApp 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 (IWithApp _ 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 (IVar 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 (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 (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 03a4f68585a..c72f6f21546 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 (Elaborable_Name _ n)) = do defs <- get Ctxt ns <- lookupTyName n (gamma defs) traverse_ printName ns diff --git a/_/AGENTS.md b/_/AGENTS.md index 7c04664e90c..0b2dd80f724 100644 --- a/_/AGENTS.md +++ b/_/AGENTS.md @@ -1,8 +1,20 @@ # 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. +## 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 @@ -18,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 diff --git a/_/EDRIC.md b/_/EDRIC.md index 06866e7cf95..d5e0c7e44c2 100644 --- a/_/EDRIC.md +++ b/_/EDRIC.md @@ -22,9 +22,24 @@ 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. + +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. ## Data-structure vocabulary @@ -52,9 +67,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 +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 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. +- 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. - Canonical Unicode pretty-printing is not yet claimed by this input-syntax slice. diff --git a/_/docs/source/backends/backend-cookbook.rst b/_/docs/source/backends/backend-cookbook.rst index 4e77c598055..67f7a884b14 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 ~~~~~~~~~~~~~~~~~~~ diff --git a/_/edric b/_/edric index 7b9728ce733..c2644b83a60 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 @@ -50,7 +52,9 @@ smoke_test() { run_test idris2/basic/edric004 run_test idris2/basic/edric005 run_test idris2/basic/edric006 + run_test idris2/basic/edric007 run_test idris2/basic/edric009 + sh "$repo_root/scripts/test-one-step-emitter.sh" } command=${1:-all} @@ -86,6 +90,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 diff --git a/_/examples/compiler-one-step/PrintX.idric b/_/examples/compiler-one-step/PrintX.idric new file mode 100644 index 00000000000..936f6ea84e8 --- /dev/null +++ b/_/examples/compiler-one-step/PrintX.idric @@ -0,0 +1,4 @@ +module PrintX + +main : IO () +main = putChar 'X' diff --git a/_/examples/unified-higher-mathematics/ComplexPairAgreement.idric b/_/examples/unified-higher-mathematics/ComplexPairAgreement.idric new file mode 100644 index 00000000000..7f29b365cca --- /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 00000000000..2ed5ab92419 --- /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/_/examples/unified-higher-mathematics/ComplexProjective.idric b/_/examples/unified-higher-mathematics/ComplexProjective.idric new file mode 100644 index 00000000000..37e9a065460 --- /dev/null +++ b/_/examples/unified-higher-mathematics/ComplexProjective.idric @@ -0,0 +1,188 @@ +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. +public export +data ComplexCoordinates : Type → CoordinateRank → Type where + NoComplexCoordinates : + {complex : Type} → + ComplexCoordinates complex Z + ComplexCoordinate : + {complex : Type} → + {remaining : CoordinateRank} → + complex → + ComplexCoordinates complex remaining → + ComplexCoordinates complex (S remaining) + +export +map_complex_coordinates : + {source : Type} → + {target : Type} → + {dimension : CoordinateRank} → + (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) + +public export +scale_complex_coordinates : + {complex : Type} → + {dimension : CoordinateRank} → + (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. +public 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. +public 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. +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) = + 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. +public export +projective_rescaling_witness : + {complex : Type} → + {projective_dimension : CoordinateRank} → + (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. +public export +affine_to_projective : + {complex : Type} → + {projective_dimension : CoordinateRank} → + 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 + +public export +divide_coordinates_by : + {complex : Type} → + {dimension : CoordinateRank} → + (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. +public export +projective_first_chart : + {complex : Type} → + {projective_dimension : CoordinateRank} → + (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 00000000000..d464b2e4c0f --- /dev/null +++ b/_/examples/unified-higher-mathematics/ComplexProjectiveTests.idric @@ -0,0 +1,116 @@ +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 + +-- 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" diff --git a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric index 29cdb8ae593..841bd936ea3 100644 --- a/_/examples/unified-higher-mathematics/EuclideanGeometry.idric +++ b/_/examples/unified-higher-mathematics/EuclideanGeometry.idric @@ -2,125 +2,124 @@ module EuclideanGeometry import MathematicalSpaces -%default total %unbound_implicits off -- A finite coordinate space does not acquire a dot product merely from its -- 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 : ℕ} -> - {name : SpaceName rank} -> + {rank : CoordinateRank} → + {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 → ±Number +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 → ±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 : - {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 → ±Number +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 -- -------------------------------------------------------------------------- public export -data Quaternion = Q Integer Integer Integer Integer +data Quaternion = Q ±Number ±Number ±Number ±Number 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) @@ -128,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 → ±Number +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 = the ±Number 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 @@ -179,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. @@ -194,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 : ℕ} -> - {name : SpaceName (S n)} -> + {n : CoordinateRank} → + {name : SpaceName (S n)} → OrthogonalTransform {space = NamedFiniteSpace name} StandardCoordinate Reversing FirstPlaneQuarterTurnTransform : - {n : ℕ} -> - {name : SpaceName (S (S n))} -> + {n : CoordinateRank} → + {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 : ℕ} -> - {name : SpaceName (S n)} -> - (structure : EuclideanStructure (NamedFiniteSpace name)) -> +first_axis_reflection : + {n : CoordinateRank} → + {name : SpaceName (S n)} → + (structure : EuclideanStructure (NamedFiniteSpace name)) → OrthogonalTransform structure Reversing -firstAxisReflection StandardCoordinate = FirstAxisReflectionTransform +first_axis_reflection StandardCoordinate = FirstAxisReflectionTransform public export -firstPlaneQuarterTurn : - {n : ℕ} -> - {name : SpaceName (S (S n))} -> - (structure : EuclideanStructure (NamedFiniteSpace name)) -> +first_plane_quarter_turn : + {n : CoordinateRank} → + {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 @@ -285,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 @@ -294,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 : ℕ} -> - {name : SpaceName (S n)} -> - (structure : EuclideanStructure (NamedFiniteSpace name)) -> - ExactVectorSample (NamedFiniteSpace name) -> +apply_first_axis_reflection : + {n : CoordinateRank} → + {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 : ℕ} -> - {name : SpaceName (S (S n))} -> - (structure : EuclideanStructure (NamedFiniteSpace name)) -> - ExactVectorSample (NamedFiniteSpace name) -> +apply_first_plane_quarter_turn : + {n : CoordinateRank} → + {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/FormTests.idric b/_/examples/unified-higher-mathematics/FormTests.idric new file mode 100644 index 00000000000..f486912cf0e --- /dev/null +++ b/_/examples/unified-higher-mathematics/FormTests.idric @@ -0,0 +1,351 @@ +module FormTests + +import MathematicalSpaces +import QuadraticForms + +%unbound_implicits off + +-- -------------------------------------------------------------------------- +-- Abstract forms and the quadratic/polar distinction +-- -------------------------------------------------------------------------- + +bilinear_evaluation_test : + evaluate_bilinear + (BilinearTensor plane_x plane_y) + (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) + (plane_vector 3 4)) + (plane_vector 5 7) = the ±Number 21 +bilinear_to_dual_test = Refl + +quadratic_evaluation_test : + 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 (plane_vector 3 4) + = the ±Number 12 +primitive_cross_term_test = Refl + +polar_cross_term_test : + evaluate_symmetric + (polar_form plane_cross_quadratic) + (plane_vector 1 0) + (plane_vector 0 1) = the ±Number 1 +polar_cross_term_test = Refl + +polar_difference_test : + polar_difference + plane_cross_quadratic + (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 in the exact integral model. +quadratic_diagonal_value_test : + 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) + (plane_vector 1 1) + (plane_vector 1 1) = the ±Number 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_integral_symmetric_presentation : + DiagonalPresentation plane_cross_quadratic + odd_cross_term_has_no_integral_symmetric_presentation = + SquareHasDiagonalPresentation plane_x + +-- -------------------------------------------------------------------------- +-- Refinements carry evidence rather than 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 + +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 + +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 = 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 (plane_vector 2 1) + = the ±Number 3 +indefinite_positive_witness_test = Refl + +indefinite_negative_witness_test : + 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 (plane_vector 1 1) + = the ±Number 0 +isotropic_witness_test = Refl + +degenerate_direction_test : + evaluate_quadratic plane_first_square (plane_vector 0 1) + = the ±Number 0 +degenerate_direction_test = Refl + +-- -------------------------------------------------------------------------- +-- Hermitian and sesquilinear semantics +-- -------------------------------------------------------------------------- + +complex_left : ExactComplexVectorSample plane_space +complex_left = complex_plane_vector (Complex 1 1) complex_zero + +complex_right : ExactComplexVectorSample plane_space +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))) = the ±Number 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" + 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 plane_space + ordinary_quadratic_is_not_hermitian = plane_positive_quadratic + +failing "Mismatch between" + ordinary_vector_is_not_complex_vector : ExactComplex + ordinary_vector_is_not_complex_vector = + evaluate_hermitian + plane_standard_hermitian + (plane_vector 1 0) + (plane_vector 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) + (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) + (plane_vector 2 1) = the ±Number 11 +basis_independent_value_from_sheared_gram_test = Refl + +underlying_form_value_test : + evaluate_quadratic plane_weighted_quadratic (plane_vector 2 1) + = the ±Number 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 = + HermitianEntries2 1 complex_zero 1 +standard_hermitian_gram_test = Refl + +sheared_hermitian_gram_test : + hermitian_gram_entries sheared_hermitian_gram = + HermitianEntries2 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))) = 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))) = the ±Number 7 +hermitian_basis_independent_sheared_value_test = Refl + +-- -------------------------------------------------------------------------- +-- Characteristic two: 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" diff --git a/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md b/_/examples/unified-higher-mathematics/HIGH_DIMENSIONAL_VERIFICATION.md index 13ddbb533db..09f847d0388 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. @@ -85,14 +85,14 @@ 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. 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 0aec4ce7d7b..6cba2e40136 100644 --- a/_/examples/unified-higher-mathematics/MathematicalSpaces.idric +++ b/_/examples/unified-higher-mathematics/MathematicalSpaces.idric @@ -1,15 +1,26 @@ module MathematicalSpaces -%default total %unbound_implicits off +-- Signed whole numbers keep their Idriç-facing name in this exact sample. +-- Integer is only the inherited bootstrap representation at this boundary. +public export +±Number : Type +±Number = Integer + +-- Coordinate rank is a semantic name for the current Number-indexed shape. +-- It is not a separate Cardinality type. +public export +CoordinateRank : Type +CoordinateRank = Number + -- This module is the small common semantic core shared by the Euclidean, --- indexed-contraction, and topology experiments. Space names are indexed by +-- indexed-contraction, and topology experiments. Space names are indexed by -- their known rank, so one name cannot be paired with contradictory ranks. -- 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,256 +28,259 @@ 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 (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 +-- ±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. +-- 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. --- UNSAFE REPRESENTATION BOUNDARY. The raw coordinates, their constructors, +-- UNSAFE REPRESENTATION BOUNDARY. The raw coordinates, their constructors, -- and every operation that exposes or rebuilds them are deliberately named --- Raw... or Unsafe... . They remain public only so the exact #47 fixture and +-- Raw... or Unsafe... . They remain public only so the exact #47 fixture and -- the closed transform interpreter can be compiler-normalized across modules. -- Using this boundary, a caller can explicitly discard a role or space name by --- destructing and rebuilding coordinates. The ordinary semantic API below +-- destructing and rebuilding coordinates. The ordinary semantic API below -- never performs such a conversion implicitly. public export -data RawExactCoordinates : ℕ -> Type where +data RawExactCoordinates : Number → Type where UnsafeCoordinateNil : RawExactCoordinates Z UnsafeCoordinateCons : - {n : ℕ} -> - Integer -> RawExactCoordinates n -> RawExactCoordinates (S n) + {n : Number} → + ±Number → RawExactCoordinates n → RawExactCoordinates (S n) public export -unsafeZeroCoordinates : (n : ℕ) -> 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 : ℕ} -> - 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 : ℕ} -> 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 : ℕ} -> - 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 : ℕ} -> Integer -> RawExactCoordinates n -> RawExactCoordinates n -unsafeScaleCoordinates scalar UnsafeCoordinateNil = UnsafeCoordinateNil -unsafeScaleCoordinates scalar (UnsafeCoordinateCons value rest) = +unsafe_scale_coordinates : + {n : Number} → ±Number → 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 +-- 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 : ℕ} -> - 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 → ±Number +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. +-- 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 : ℕ} -> - {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 : ℕ} -> - {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} → + ±Number → 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} → + ±Number → 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 +-- Evaluation is the canonical vector/covector contraction. There is no safe -- exact-vector-sample to exact-covector-sample conversion in this module and -- hence no metric-free dot product between two vector samples in the checked --- API. Crossing the explicitly unsafe representation boundary is not an +-- API. Crossing the explicitly unsafe representation boundary is not an -- inferred mathematical operation. public export contract : - {space : FiniteSpace} -> - ExactCovectorSample space -> ExactVectorSample space -> Integer + {space : FiniteSpace} → + ExactCovectorSample space → ExactVectorSample space → ±Number 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 : ±Number → ±Number → 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 : ±Number → ±Number → 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 : ±Number → ±Number → 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 : ±Number → ±Number → 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 : + ±Number → ±Number → ±Number → 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 : + ±Number → ±Number → ±Number → ExactCovectorSample real_three_space +three_covector first second third = UnsafeCovectorCoordinates (UnsafeCoordinateCons first (UnsafeCoordinateCons second @@ -280,17 +294,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 → ±Number +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 615f7292f98..bf8985b71f1 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,37 +12,37 @@ import TopologyFacts public export record FactProvenance where constructor MkFactProvenance - factNamespace : String - factName : String - factVersion : String + fact_namespace : Text + fact_name : Text + fact_version : Text -- A declared code-source locator, not a checked citation. - factSource : String + 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 @@ -51,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 -> String -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/PairArithmetic.idric b/_/examples/unified-higher-mathematics/PairArithmetic.idric new file mode 100644 index 00000000000..4019de6e11e --- /dev/null +++ b/_/examples/unified-higher-mathematics/PairArithmetic.idric @@ -0,0 +1,65 @@ +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) + ) + +-- 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 (first, second) (third, fourth) = + (first + third, second + fourth) + +public export +signed_pair_complex_multiply : + (±Number, ±Number) → + (±Number, ±Number) → + (±Number, ±Number) +signed_pair_complex_multiply (a, b) (c, d) = + (a * c - b * d, a * d + b * c) diff --git a/_/examples/unified-higher-mathematics/PairArithmeticTests.idric b/_/examples/unified-higher-mathematics/PairArithmeticTests.idric new file mode 100644 index 00000000000..0d93698726f --- /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/_/examples/unified-higher-mathematics/PresheafRestriction.idric b/_/examples/unified-higher-mathematics/PresheafRestriction.idric index 5509c012a23..6e8bf19b522 100644 --- a/_/examples/unified-higher-mathematics/PresheafRestriction.idric +++ b/_/examples/unified-higher-mathematics/PresheafRestriction.idric @@ -1,103 +1,161 @@ module PresheafRestriction -%default total +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 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 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 : Type → Open → Type where + WholeSection : {payload : Type} → payload → Section payload Whole + PatchSection : {payload : Type} → payload → Section payload Patch + PointSection : {payload : Type} → 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 -data ElementaryTensorSection : Open -> Type where +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 + {u : Open} → + Section ±Number u → Section ±Number 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 ±Number u) → + (right : Section ±Number 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 - -- 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 - -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_identity : + {u : Open} → + (tensor : ElementaryTensorSection u) → + restrict_tensor Same tensor = tensor +tensor_restriction_identity tensor = Refl + +public export +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/QUADRATIC-FORMS.md b/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md new file mode 100644 index 00000000000..f1db4e48351 --- /dev/null +++ b/_/examples/unified-higher-mathematics/QUADRATIC-FORMS.md @@ -0,0 +1,227 @@ +# 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 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. +- `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. 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 +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 `±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-integral coordinates. It adds +separate complex vectors and covectors rather than reinterpreting ordinary +integral 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-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 +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-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 +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 two; +- decision procedures for definiteness or degeneracy of arbitrary forms; +- 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 +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 representation +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 `IntegralMatrix2` 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 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 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: 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 +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-two and Hermitian cautions. This file links to it +rather than duplicating the chapter-by-chapter material. diff --git a/_/examples/unified-higher-mathematics/QuadraticForms.idric b/_/examples/unified-higher-mathematics/QuadraticForms.idric new file mode 100644 index 00000000000..41afd8eb2d9 --- /dev/null +++ b/_/examples/unified-higher-mathematics/QuadraticForms.idric @@ -0,0 +1,1135 @@ +module QuadraticForms + +import MathematicalSpaces + +%unbound_implicits off + +-- 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 : {space : FiniteSpace} → BilinearForm space + BilinearTensor : + {space : FiniteSpace} → + ExactCovectorSample space → + ExactCovectorSample space → + BilinearForm space + BilinearSum : + {space : FiniteSpace} → + BilinearForm space → BilinearForm space → BilinearForm space + BilinearScale : + {space : FiniteSpace} → + ±Number → BilinearForm space → BilinearForm space + +public export +evaluate_bilinear : + {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 +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 + +public export +zero_covector : + {space : FiniteSpace} → + ExactVectorSample space → + ExactCovectorSample 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. +public export +bilinear_covector_at : + {space : FiniteSpace} → + BilinearForm space → + ExactVectorSample space → + ExactCovectorSample space +bilinear_covector_at BilinearZero vector = + scale_covector 0 $ zero_covector vector +bilinear_covector_at (BilinearTensor first second) vector = + scale_covector (contract first vector) second +bilinear_covector_at (BilinearSum first second) vector = + add_covector + (bilinear_covector_at first vector) + (bilinear_covector_at second vector) +bilinear_covector_at (BilinearScale scalar form) vector = + scale_covector scalar $ bilinear_covector_at form vector + +public export +data SymmetricBilinearForm : FiniteSpace → Type where + SymmetricZero : {space : FiniteSpace} → SymmetricBilinearForm space + SymmetricSquare : + {space : FiniteSpace} → + ExactCovectorSample space → SymmetricBilinearForm space + SymmetricPair : + {space : FiniteSpace} → + ExactCovectorSample space → + ExactCovectorSample space → + SymmetricBilinearForm space + SymmetricSum : + {space : FiniteSpace} → + SymmetricBilinearForm space → + SymmetricBilinearForm space → + SymmetricBilinearForm space + SymmetricScale : + {space : FiniteSpace} → + ±Number → SymmetricBilinearForm space → SymmetricBilinearForm space + +public export +evaluate_symmetric : + {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 +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. This distinction is +-- essential before a future scalar abstraction can honestly include +-- characteristic two. +public export +data QuadraticForm : FiniteSpace → Type where + QuadraticZero : {space : FiniteSpace} → QuadraticForm space + QuadraticSquare : + {space : FiniteSpace} → + ExactCovectorSample space → QuadraticForm space + QuadraticProduct : + {space : FiniteSpace} → + ExactCovectorSample space → + ExactCovectorSample space → + QuadraticForm space + QuadraticSum : + {space : FiniteSpace} → + QuadraticForm space → QuadraticForm space → QuadraticForm space + QuadraticScale : + {space : FiniteSpace} → + ±Number → QuadraticForm space → QuadraticForm space + QuadraticFromSymmetric : + {space : FiniteSpace} → + SymmetricBilinearForm space → QuadraticForm space + +public export +evaluate_quadratic : + {space : FiniteSpace} → + QuadraticForm space → + ExactVectorSample space → + ±Number +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 + +-- 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. +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 → + ±Number +polar_difference form left right = + evaluate_quadratic form (add_vector left right) + - evaluate_quadratic form left + - evaluate_quadratic form 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. +public export +data DiagonalPresentation : + {space : FiniteSpace} → QuadraticForm space → Type where + SquareHasDiagonalPresentation : + {space : FiniteSpace} → + (covector : ExactCovectorSample space) → + DiagonalPresentation (QuadraticSquare covector) + SymmetricHasDiagonalPresentation : + {space : FiniteSpace} → + (form : SymmetricBilinearForm space) → + DiagonalPresentation (QuadraticFromSymmetric form) + SumHasDiagonalPresentation : + {space : FiniteSpace} → + {first : QuadraticForm space} → + {second : QuadraticForm space} → + DiagonalPresentation first → + DiagonalPresentation second → + DiagonalPresentation (QuadraticSum first second) + ScaleHasDiagonalPresentation : + {space : FiniteSpace} → + (scalar : ±Number) → + {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 and conjugation +-- -------------------------------------------------------------------------- + +-- This Gaussian-integral value is an exact acceptance scalar, not the future +-- general complex-number hierarchy. +public export +data ExactComplex = Complex ±Number ±Number + +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 real imaginary) = Complex (-real) (-imaginary) + +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) + +public export +conjugate : ExactComplex → ExactComplex +conjugate (Complex real imaginary) = Complex real (-imaginary) + +public export +real_part : ExactComplex → ±Number +real_part (Complex real imaginary) = real + +public export +data RawExactComplexCoordinates : CoordinateRank → Type where + UnsafeComplexCoordinateNil : RawExactComplexCoordinates Z + UnsafeComplexCoordinateCons : + {n : CoordinateRank} → + ExactComplex → + RawExactComplexCoordinates n → + RawExactComplexCoordinates (S n) + +public export +data ExactComplexVectorSample : FiniteSpace → Type where + UnsafeComplexVectorCoordinates : + {rank : CoordinateRank} → + {name : SpaceName rank} → + RawExactComplexCoordinates rank → + ExactComplexVectorSample (NamedFiniteSpace name) + +public export +data ExactComplexCovectorSample : FiniteSpace → Type where + UnsafeComplexCovectorCoordinates : + {rank : CoordinateRank} → + {name : SpaceName rank} → + 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 → + RawExactComplexCoordinates rank → + RawExactComplexCoordinates rank +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) + +public export +unsafe_scale_complex_coordinates : + {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) + +public export +unsafe_pair_complex_coordinates : + {rank : CoordinateRank} → + RawExactComplexCoordinates rank → + RawExactComplexCoordinates rank → + 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_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 plane_space +complex_plane_vector first second = + UnsafeComplexVectorCoordinates $ + UnsafeComplexCoordinateCons first $ + UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil + +public export +complex_plane_covector : + ExactComplex → ExactComplex → ExactComplexCovectorSample plane_space +complex_plane_covector first second = + UnsafeComplexCovectorCoordinates $ + UnsafeComplexCoordinateCons first $ + UnsafeComplexCoordinateCons second UnsafeComplexCoordinateNil + +public export +complex_zero_covector : + {space : FiniteSpace} → + ExactComplexVectorSample space → + ExactComplexCovectorSample space +complex_zero_covector (UnsafeComplexVectorCoordinates coordinates) = + UnsafeComplexCovectorCoordinates $ + unsafe_scale_complex_coordinates complex_zero coordinates + +-- -------------------------------------------------------------------------- +-- Sesquilinear and Hermitian forms +-- -------------------------------------------------------------------------- + +-- Convention: conjugate-linear in the first argument and linear in the second. +public export +data SesquilinearForm : FiniteSpace → Type where + SesquilinearZero : {space : FiniteSpace} → SesquilinearForm space + SesquilinearTensor : + {space : FiniteSpace} → + ExactComplexCovectorSample space → + ExactComplexCovectorSample space → + SesquilinearForm space + SesquilinearSum : + {space : FiniteSpace} → + SesquilinearForm space → SesquilinearForm space → SesquilinearForm space + SesquilinearScale : + {space : FiniteSpace} → + 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 : {space : FiniteSpace} → HermitianForm space + HermitianSquare : + {space : FiniteSpace} → + ExactComplexCovectorSample space → HermitianForm space + HermitianCross : + {space : FiniteSpace} → + ExactComplex → + ExactComplexCovectorSample space → + ExactComplexCovectorSample space → + HermitianForm space + HermitianSum : + {space : FiniteSpace} → + HermitianForm space → HermitianForm space → HermitianForm space + HermitianScale : + {space : FiniteSpace} → + ±Number → 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 = + scale_complex_integral 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 sample exposes that real quantity as ±Number rather than pretending +-- that H is an ordinary complex QuadraticForm. +public export +hermitian_quadratic_quantity : + {space : FiniteSpace} → + HermitianForm space → + ExactComplexVectorSample space → + ±Number +hermitian_quadratic_quantity form vector = + real_part $ evaluate_hermitian form vector vector + +-- H(x,-) is a linear complex covector. As a map from x into the dual, this is +-- conjugate-linear under the convention above. +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) + +-- -------------------------------------------------------------------------- +-- Evidence-bearing refinements on the exact plane sample +-- -------------------------------------------------------------------------- + +public export +plane_x : ExactCovectorSample plane_space +plane_x = plane_covector 1 0 + +public export +plane_y : ExactCovectorSample plane_space +plane_y = plane_covector 0 1 + +public export +plane_positive_quadratic : QuadraticForm plane_space +plane_positive_quadratic = + QuadraticSum (QuadraticSquare plane_x) (QuadraticSquare plane_y) + +public export +plane_negative_quadratic : QuadraticForm plane_space +plane_negative_quadratic = QuadraticScale (-1) plane_positive_quadratic + +public export +plane_first_square : QuadraticForm plane_space +plane_first_square = QuadraticSquare plane_x + +public export +plane_negative_first_square : QuadraticForm plane_space +plane_negative_first_square = QuadraticScale (-1) plane_first_square + +public export +plane_difference_of_squares : QuadraticForm plane_space +plane_difference_of_squares = + QuadraticSum + (QuadraticSquare plane_x) + (QuadraticScale (-1) $ QuadraticSquare plane_y) + +public export +plane_cross_quadratic : QuadraticForm plane_space +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 : + {space : FiniteSpace} → + {form : QuadraticForm space} → + PositiveDefinite form → PositiveSemidefinite form + PlaneFirstSquareSemidefinite : PositiveSemidefinite plane_first_square + +public export +data NegativeSemidefinite : + {space : FiniteSpace} → QuadraticForm space → Type where + NegativeDefiniteIsSemidefinite : + {space : FiniteSpace} → + {form : QuadraticForm space} → + NegativeDefinite form → NegativeSemidefinite form + NegativePlaneFirstSquareSemidefinite : + NegativeSemidefinite plane_negative_first_square + +public export +data QuadraticNondegenerate : + {space : FiniteSpace} → QuadraticForm space → Type where + PositiveDefiniteIsNondegenerate : + {space : FiniteSpace} → + {form : QuadraticForm space} → + PositiveDefinite form → QuadraticNondegenerate form + NegativeDefiniteIsNondegenerate : + {space : FiniteSpace} → + {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 : + {space : FiniteSpace} → + {form : QuadraticForm space} → + PositiveDefinite form → Anisotropic form + NegativeDefiniteIsAnisotropic : + {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. +public export +data IntegralQuadratic : + {space : FiniteSpace} → QuadraticForm space → Type where + ExactIntegralValued : + {space : FiniteSpace} → + (form : QuadraticForm space) → IntegralQuadratic form + +public export +data EvenQuadratic : + {space : FiniteSpace} → QuadraticForm space → Type where + TwiceIntegralFormIsEven : + {space : FiniteSpace} → + (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 plane_space +complex_x = complex_plane_covector complex_one complex_zero + +public export +complex_y : ExactComplexCovectorSample plane_space +complex_y = complex_plane_covector complex_zero complex_one + +public export +plane_standard_hermitian : HermitianForm plane_space +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 : + {space : FiniteSpace} → + {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 two-dimensional Gram representations +-- -------------------------------------------------------------------------- + +-- There is not yet a general Basis/Matrix ontology. These local representation +-- types establish the abstraction boundary without defining a form as a matrix. +public export +data IntegralMatrix2 = Matrix2 ±Number ±Number ±Number ±Number + +public export +data SymmetricIntegralMatrix2 = SymmetricMatrix2 ±Number ±Number ±Number + +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) + (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 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 + +public export +data GramMatrix : PlaneBasis → Type where + Gram : (basis : PlaneBasis) → SymmetricIntegralMatrix2 → GramMatrix basis + +public export +gram_entries : {basis : PlaneBasis} → GramMatrix basis → SymmetricIntegralMatrix2 +gram_entries (Gram basis matrix) = matrix + +public export +gram_matrix : + SymmetricBilinearForm plane_space → + (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 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)) + +public export +represented_quadratic_form : + {basis : PlaneBasis} → + GramMatrix basis → + QuadraticForm plane_space +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 + +public export +congruence_from : + {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_integral_matrix + (transpose_integral_matrix change) + (full_symmetric_matrix matrix) + in multiply_integral_matrix left change + +public export +plane_weighted_symmetric : SymmetricBilinearForm plane_space +plane_weighted_symmetric = + SymmetricSum + (SymmetricScale 2 $ SymmetricSquare plane_x) + (SymmetricScale 3 $ SymmetricSquare plane_y) + +public export +plane_weighted_quadratic : QuadraticForm plane_space +plane_weighted_quadratic = + quadratic_from_symmetric plane_weighted_symmetric + +-- -------------------------------------------------------------------------- +-- Basis-dependent Hermitian representations +-- -------------------------------------------------------------------------- + +public export +data ExactComplexMatrix2 = + ComplexMatrix2 ExactComplex ExactComplex ExactComplex ExactComplex + +public export +data HermitianMatrix2 = HermitianEntries2 ±Number ExactComplex ±Number + +public export +full_hermitian_matrix : HermitianMatrix2 → ExactComplexMatrix2 +full_hermitian_matrix (HermitianEntries2 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 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 plane_space +complex_basis_second StandardComplexBasis = + complex_plane_vector complex_zero complex_one +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 = + complex_plane_covector complex_one complex_zero +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 = + 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 plane_space → + (basis : ComplexPlaneBasis) → + HermitianGramMatrix basis +hermitian_gram_matrix form basis = + HermitianGram basis $ + HermitianEntries2 + (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 plane_space +represented_hermitian_form + (HermitianGram basis (HermitianEntries2 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 + +-- Kept only as a negative oracle: ordinary transpose is not the Hermitian +-- basis-change operation. +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-two acceptance model +-- -------------------------------------------------------------------------- + +-- 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. +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 + +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) + +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)) diff --git a/_/examples/unified-higher-mathematics/README.md b/_/examples/unified-higher-mathematics/README.md index 6977fe06cbf..6aa64172f86 100644 --- a/_/examples/unified-higher-mathematics/README.md +++ b/_/examples/unified-higher-mathematics/README.md @@ -1,53 +1,54 @@ # 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` -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 `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 -identification through `lowerIndex` and `raiseIndex`; `dot`, `norm`, +`MathematicalSpaces`. `EuclideanStructure space` supplies that additional +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 -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. `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 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 @@ -56,17 +57,61 @@ 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` +`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 `lower_indexed` or `raise_indexed` 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 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 -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: @@ -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. diff --git a/_/examples/unified-higher-mathematics/Tests.idric b/_/examples/unified-higher-mathematics/Tests.idric index ca82946298d..c29b440ccc1 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 @@ -18,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) = the ±Number 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)) + = the ±Number 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) + = 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 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 @@ -61,56 +60,56 @@ failing "Mismatch between: 0 and 1." NamedFiniteSpace {rank = 3} PlaneName failing "Mismatch between: RealThreeName and PlaneName." - mismatched_dimension_contraction : Integer + mismatched_dimension_contraction : ±Number 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 : ±Number 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" - vector_vector_contraction_without_euclidean_structure : Integer +failing "Mismatch between: ExactVectorSample plane_space and ExactCovectorSample" + vector_vector_contraction_without_euclidean_structure : ±Number 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) = the ±Number 43 metric_dot_test = Refl metric_squared_norm_test : - squaredNorm planeEuclidean (planeVector 3 4) = 25 + squared_norm plane_euclidean (plane_vector 3 4) = the ±Number 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) = the ±Number 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 -- -------------------------------------------------------------------------- @@ -118,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)) = 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 = - 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 : ±Number 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)) = the ±Number 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 -- -------------------------------------------------------------------------- @@ -161,200 +160,201 @@ 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 Z value = UnsafeCoordinateCons value UnsafeCoordinateNil -lastCoordinate (S n) value = - UnsafeCoordinateCons 0 (lastCoordinate n value) +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) 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) = the ±Number 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) = the ±Number 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) = the ±Number 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) = the ±Number 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 : ℕ} -> RawExactCoordinates (S n) -> Integer -lastCoordinateValue (UnsafeCoordinateCons value UnsafeCoordinateNil) = value -lastCoordinateValue - (UnsafeCoordinateCons _ rest@(UnsafeCoordinateCons _ _)) = lastCoordinateValue rest +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 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)) = the ±Number 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)) = the ±Number 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 = the Number 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 = the Number 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 = the Number 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 = the Number 1 sphere_s2_h2_rank_test = Refl -odd_sphere_euler_test : sphereEulerCharacteristic 3 = 0 +odd_sphere_euler_test : sphere_euler_characteristic 3 = the ±Number 0 odd_sphere_euler_test = Refl -even_sphere_euler_test : sphereEulerCharacteristic 4 = 2 +even_sphere_euler_test : sphere_euler_characteristic 4 = the ±Number 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 = the ±Number 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 = the Number 6 cp3_real_dimension_test = Refl -cp3_hopf_sphere_dimension_test : cpHopfSphereDimension 3 = 7 +cp3_hopf_sphere_dimension_test : cp_hopf_sphere_dimension 3 = the Number 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 = the Number 1 cp2_h0_rank_test = Refl -cp2_h2_rank_test : cpIntegralCohomologyRank 2 2 = 1 +cp2_h2_rank_test : cp_integral_cohomology_rank 2 2 = the Number 1 cp2_h2_rank_test = Refl -cp2_h4_rank_test : cpIntegralCohomologyRank 2 4 = 1 +cp2_h4_rank_test : cp_integral_cohomology_rank 2 4 = the Number 1 cp2_h4_rank_test = Refl -cp2_h3_rank_test : cpIntegralCohomologyRank 2 3 = 0 +cp2_h3_rank_test : cp_integral_cohomology_rank 2 3 = the Number 0 cp2_h3_rank_test = Refl -cp2_h6_rank_test : cpIntegralCohomologyRank 2 6 = 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 : - compactifiedSphereDimension (euclideanOnePointCompactification 3) = 3 + compactified_sphere_dimension (euclidean_one_point_compactification 3) = + the Number 3 r3_one_point_compactifies_to_s3_test = Refl -- -------------------------------------------------------------------------- @@ -365,77 +365,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) = the Number 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 d673ba2d287..27799888e2f 100644 --- a/_/examples/unified-higher-mathematics/TopologyFacts.idric +++ b/_/examples/unified-higher-mathematics/TopologyFacts.idric @@ -3,156 +3,151 @@ module TopologyFacts import MathematicalSpaces import EuclideanGeometry -%default total %unbound_implicits off -- This module preserves the settled elementary topology facts from #45 while --- keeping their source distinct from ordinary type unification. The functions +-- keeping their source distinct from ordinary type unification. The functions -- below expose known closed formulas and the datatypes expose named theorem --- boundaries. Nothing here computes general cohomology, constructs arbitrary +-- boundaries. Nothing here computes general cohomology, constructs arbitrary -- quotients, or proves a separation theorem from coordinates. +public export +Dimension : Type +Dimension = Number + +public export +CohomologicalDegree : Type +CohomologicalDegree = Number + +public export +CohomologyRank : Type +CohomologyRank = Number + +public export +EulerCharacteristic : Type +EulerCharacteristic = ±Number + +public export +ConnectedComponentCount : Type +ConnectedComponentCount = Number + -- -------------------------------------------------------------------------- -- Spheres in explicitly Euclidean ambient spaces -- -------------------------------------------------------------------------- --- A checked exact sample carries its norm-one equality. Indexing by the --- Euclidean structure, rather than only its coordinate count, prevents a point --- from silently moving to an equal-rank different named space. General sphere --- actions are deliberately not fabricated here: the exact transform evaluator --- lives in EuclideanGeometry, while a reusable norm-preservation proof layer is --- 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 = the ±Number 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 : ℕ -> ℕ -> ℕ -sphereIntegralCohomologyRank Z Z = 2 -sphereIntegralCohomologyRank Z (S degree) = 0 -sphereIntegralCohomologyRank (S dimension) Z = 1 -sphereIntegralCohomologyRank (S dimension) (S degree) = +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 +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 : ℕ -> Parity -natParity Z = Even -natParity (S n) = flipParity (natParity 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 -sphereEulerCharacteristic : ℕ -> Integer -sphereEulerCharacteristic dimension = - case natParity dimension of - Even => 2 - Odd => 0 +sphere_euler_characteristic : Dimension → EulerCharacteristic +sphere_euler_characteristic dimension = + case dimension_parity dimension of + Even ⇒ 2 + Odd ⇒ 0 -- -------------------------------------------------------------------------- -- Complex projective-space facts -- -------------------------------------------------------------------------- --- CP^n has complex dimension n and real dimension 2n. public export -cpRealDimension : ℕ -> ℕ -cpRealDimension n = n + n +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 -cpHopfSphereDimension : ℕ -> ℕ -cpHopfSphereDimension n = S (n + n) +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 -cpIntegralCohomologyRank : ℕ -> ℕ -> ℕ -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 : + 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 +cp_integral_cohomology_rank (S n) (S (S degree)) = + cp_integral_cohomology_rank n degree public export -data HopfQuotientFact : ℕ -> Type where - CPnAsSphereByCircle : (n : ℕ) -> HopfQuotientFact n +data HopfQuotientFact : Dimension → Type where + CPnAsSphereByCircle : (n : Dimension) → HopfQuotientFact n public export -cpHopfQuotient : (n : ℕ) -> HopfQuotientFact n -cpHopfQuotient n = CPnAsSphereByCircle n +cp_hopf_quotient : (n : Dimension) → HopfQuotientFact n +cp_hopf_quotient n = CPnAsSphereByCircle n -- -------------------------------------------------------------------------- -- Named theorem-boundary facts -- -------------------------------------------------------------------------- --- A value of EmbeddedCircleInS2 is an explicit assumption token for the --- hypothesis "there is a chosen embedded circle in S^2". This example does --- not construct a map or check injectivity. JordanSeparation is the named --- conclusion used by the tiny fact experiment; the compiler does not derive --- it by unification. 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 -> ℕ -complementComponentCount (ExactlyTwoComplementComponents curve) = 2 +complement_component_count : + {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 : ℕ -> Type where +data EuclideanCompactificationFact : Dimension → Type where EuclideanPlusIsSphere : - (dimension : ℕ) -> EuclideanCompactificationFact dimension + (dimension : Dimension) → EuclideanCompactificationFact dimension public export -euclideanOnePointCompactification : - (dimension : ℕ) -> EuclideanCompactificationFact dimension -euclideanOnePointCompactification dimension = +euclidean_one_point_compactification : + (dimension : Dimension) → EuclideanCompactificationFact dimension +euclidean_one_point_compactification dimension = EuclideanPlusIsSphere dimension public export -compactifiedSphereDimension : - {n : ℕ} -> EuclideanCompactificationFact n -> ℕ -compactifiedSphereDimension (EuclideanPlusIsSphere dimension) = dimension +compactified_sphere_dimension : + {n : Dimension} → EuclideanCompactificationFact n → Dimension +compactified_sphere_dimension (EuclideanPlusIsSphere dimension) = dimension diff --git a/_/examples/units-time-intervals/Tests.idric b/_/examples/units-time-intervals/Tests.idric new file mode 100644 index 00000000000..ad8300db694 --- /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" diff --git a/_/examples/units-time-intervals/UnitsTimeIntervals.idric b/_/examples/units-time-intervals/UnitsTimeIntervals.idric new file mode 100644 index 00000000000..0261c077b3b --- /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. diff --git a/_/fixtures/complex-projective/float32.json b/_/fixtures/complex-projective/float32.json new file mode 100644 index 00000000000..bfe8e63de85 --- /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/_/idris2api.ipkg b/_/idris2api.ipkg index a0f4831fe16..dbd0a1e346e 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, diff --git a/_/koans/01-values-types-and-holes/exercise/Main.idric b/_/koans/01-values-types-and-holes/exercise/Main.idric index 4b713c687b3..23264768e89 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 267deecadf5..e0b78b492a7 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 d183485dd89..3a7d65e5681 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 d6fe805ebb7..4333db3c03a 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 c064df6789d..9dbdb817b32 100644 --- a/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/exercise/Main.idric @@ -2,10 +2,8 @@ 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 ℕ 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 c3c24387b8b..f1bba66784e 100644 --- a/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric +++ b/_/koans/03-lists-and-length-indexed-lists/solution/Main.idric @@ -2,10 +2,8 @@ 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 ℕ diff --git a/_/koans/04-equality-proofs/exercise/Main.idric b/_/koans/04-equality-proofs/exercise/Main.idric index ba39bc1bc28..1f435d86cf7 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 e4eb157ffac..772e4cc7350 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 2c73df8c753..ecefe74c6b3 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 7f7016f69b4..699f533e594 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 83c1c5acebd..b0bf9e0e263 100644 --- a/_/koans/06-implicit-dependent-results/exercise/Main.idric +++ b/_/koans/06-implicit-dependent-results/exercise/Main.idric @@ -2,8 +2,6 @@ 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 item items = ?dependent_result diff --git a/_/koans/06-implicit-dependent-results/solution/Main.idric b/_/koans/06-implicit-dependent-results/solution/Main.idric index e5b1c848a16..b86221891c4 100644 --- a/_/koans/06-implicit-dependent-results/solution/Main.idric +++ b/_/koans/06-implicit-dependent-results/solution/Main.idric @@ -2,8 +2,6 @@ module Main import Data.Vect -%default total - prepend : {n : ℕ} → a → Vect n a → Vect (S n) a prepend item items = item :: items diff --git a/_/koans/07-erased-arguments/exercise/Main.idric b/_/koans/07-erased-arguments/exercise/Main.idric index e8ff56fd886..58010ab84c9 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 9932fa6a541..dae35b83381 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 1fe0642958d..2f96fe4523a 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 b7f753befba..a1dc05ce595 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 dda7b6a1af8..ff55fa9045e 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 72dc2cf5eb1..e97c080f1c6 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 37c24545a2f..24bff826f44 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 fe98651165b..1292af67c31 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 21ff3d0d38d..e10dc9702e3 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 da3238dd8d5..43d92ab305b 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 31ef285f41c..3df42502d71 100644 --- a/_/koans/12-wegert-model/exercise/Main.idric +++ b/_/koans/12-wegert-model/exercise/Main.idric @@ -2,29 +2,27 @@ 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 diff --git a/_/koans/12-wegert-model/solution/Main.idric b/_/koans/12-wegert-model/solution/Main.idric index 348eb8599e8..809b69d4ed1 100644 --- a/_/koans/12-wegert-model/solution/Main.idric +++ b/_/koans/12-wegert-model/solution/Main.idric @@ -2,30 +2,28 @@ 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 diff --git a/_/scripts/emit-one-step.sh b/_/scripts/emit-one-step.sh new file mode 100644 index 00000000000..7da4eb15a2c --- /dev/null +++ b/_/scripts/emit-one-step.sh @@ -0,0 +1,80 @@ +#!/bin/sh +set -eu + +support_root=$(CDPATH='' cd -- "$(dirname -- "$0")/.." && pwd) +compiler="$support_root/build/exec/idris2" + +usage() { + echo "usage: ./_/edric --emit-one-step SOURCE -o ARTIFACT" >&2 + exit 2 +} + +[ "$#" -eq 3 ] || usage +source=$1 +case "$2" in + -o|--output) ;; + *) usage ;; +esac +output=$3 + +[ -f "$source" ] || { echo "Idric one-step emitter: source not found: $source" >&2; exit 2; } +[ -x "$compiler" ] || { + echo "Idric one-step emitter: compiler is not bootstrapped; run ./_/edric bootstrap" >&2 + exit 2 +} + +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" + +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 + +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" +) + +[ "$(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 +} + +set -- $(sha256sum "$source_path") +source_sha256=$1 +set -- $(sha256sum "$body_path") +body_sha256=$1 +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' + tail -n +2 "$body_path" + printf 'definitions_end\n' + printf 'end\n' +} > "$tmp" +mv "$tmp" "$output_path" +rm -rf "$build_dir" +trap - EXIT HUP INT TERM diff --git a/_/scripts/test-one-step-emitter.sh b/_/scripts/test-one-step-emitter.sh new file mode 100644 index 00000000000..b157586f714 --- /dev/null +++ b/_/scripts/test-one-step-emitter.sh @@ -0,0 +1,33 @@ +#!/bin/sh +set -eu + +support_root=$(CDPATH='' cd -- "$(dirname -- "$0")/.." && pwd) +source="$support_root/examples/compiler-one-step/PrintX.idric" +temporary=$(mktemp -d) +trap 'rm -rf "$temporary"' EXIT HUP INT TERM + +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' + sed -n '/^definitions_begin$/,/^definitions_end$/p' "$first" | sed '1d;$d' +} > "$body" +body_sha=$(sha256sum "$body" | cut -d' ' -f1) +grep -Fx "$(printf 'body_sha256\t%s' "$body_sha")" "$first" + +printf '%s\n' 'Idric compiler one-step emitter: PASS' diff --git a/_/tests/idris2/basic/edric002/WegertSource.idric b/_/tests/idris2/basic/edric002/WegertSource.idric index 4dfaf638557..ccecbc165fa 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 1bdb4f1e2eb..fbca646de8f 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 -> 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 -identity : a -> a +identity : a → a identity value = value main : IO () diff --git a/_/tests/idris2/basic/edric003/WegertTouch.idric b/_/tests/idris2/basic/edric003/WegertTouch.idric index 8e10b3692a4..cddf741c653 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/IdrisCompat.idr b/_/tests/idris2/basic/edric005/IdrisCompat.idr index b669ea4177b..4db683c08dc 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 0ca646cdb2b..d7a9f77cce5 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 @@ -17,9 +18,12 @@ unicode_order = 1≤2 ascii_order : Bool ascii_order = 1 <= 2 -syntax_literal : String +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 b2f815bf30b..69989638d0b 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"] -> => → ⇒ ← ≤ diff --git a/_/tests/idris2/basic/edric007/expected b/_/tests/idris2/basic/edric007/expected new file mode 100644 index 00000000000..c76749599cf --- /dev/null +++ b/_/tests/idris2/basic/edric007/expected @@ -0,0 +1 @@ +units, time, intervals: tests typecheck diff --git a/_/tests/idris2/basic/edric007/run b/_/tests/idris2/basic/edric007/run new file mode 100755 index 00000000000..999ebcf9656 --- /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 diff --git a/_/tests/idris2/basic/edric009/expected b/_/tests/idris2/basic/edric009/expected index 3b24608c0d1..5c2e78738d6 100644 --- a/_/tests/idris2/basic/edric009/expected +++ b/_/tests/idris2/basic/edric009/expected @@ -3,3 +3,7 @@ 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 +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 474e43be1d3..63106698484 100755 --- a/_/tests/idris2/basic/edric009/run +++ b/_/tests/idris2/basic/edric009/run @@ -11,8 +11,16 @@ 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/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" # Preserve .idric all the way into the bootstrapped compiler. The previous # geometry runner renamed its sources to .idr; this receipt exercises the @@ -31,4 +39,52 @@ cp "$example_dir/Tests.idric" "$fixture_dir/Tests.idric" fi ./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 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 + 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 + + 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 ) diff --git a/_/tests/testutils.sh b/_/tests/testutils.sh old mode 100755 new mode 100644 index 52c22d8f72a..21c0d686574 --- 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" @@ -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" diff --git a/edric b/edric new file mode 100755 index 00000000000..9e695e680df --- /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 diff --git a/examples/intent/http_server/README.md b/examples/intent/http_server/README.md new file mode 100644 index 00000000000..8eaf660669e --- /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. diff --git a/examples/intent/railway/README.md b/examples/intent/railway/README.md new file mode 100644 index 00000000000..7df8810bf7a --- /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. diff --git a/notes/resource-interface-deep-dive.md b/notes/resource-interface-deep-dive.md new file mode 100644 index 00000000000..7caa7225a85 --- /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