|
| 1 | +open import 1Lab.Reflection.Signature |
| 2 | +open import 1Lab.Reflection.Subst |
| 3 | +open import 1Lab.Reflection |
| 4 | +open import 1Lab.Path |
| 5 | +open import 1Lab.Type |
| 6 | + |
| 7 | +module 1Lab.Reflection.Copattern where |
| 8 | + |
| 9 | +-------------------------------------------------------------------------------- |
| 10 | +-- Macros for manipulating copattern definitions. |
| 11 | + |
| 12 | +-- Make a top-level copattern binding for an existing record. |
| 13 | +make-copattern : Bool → Name → Term → Term → TC ⊤ |
| 14 | +make-copattern declare? def-name tm tp = do |
| 15 | + -- Ensure that codomain is a record type. |
| 16 | + let tele , cod-tp = pi-view tp |
| 17 | + def rec-name params ← pure cod-tp |
| 18 | + where _ → typeError [ "make-copattern: codomain of " , termErr tp , " is not a record type." ] |
| 19 | + |
| 20 | + let inst-tm = apply-tm* tm (tel→args 0 tele) |
| 21 | + |
| 22 | + -- Construct copattern clauses for each field. |
| 23 | + ctor , fields ← get-record-type rec-name |
| 24 | + clauses ← |
| 25 | + in-context (reverse tele) $ |
| 26 | + for fields λ (arg field-info field-name) → do |
| 27 | + -- Infer the type of the field with all known arguments instantiated. |
| 28 | + field-tp ← infer-type (def field-name (argN inst-tm ∷ [])) |
| 29 | + |
| 30 | + -- Agda will insert implicits when defining copatterns even |
| 31 | + -- with 'withExpandLast true', so we need to do implicit instantiation |
| 32 | + -- by hand. There are also cases where it's better to fully |
| 33 | + -- eta-expand than not (e.g. the 'helper' we're expanding has a |
| 34 | + -- field defined by lazy matching, which does not reduce unless |
| 35 | + -- applied, and would cause duplication of the big input term). So |
| 36 | + -- we fully eta-expand clauses here. |
| 37 | + -- First, we strip off all leading quantifiers from the field |
| 38 | + -- type. |
| 39 | + let |
| 40 | + (field-tele , tp) = pi-view field-tp |
| 41 | + nargs = length field-tele |
| 42 | + clause-tele = tele ++ field-tele |
| 43 | + |
| 44 | + -- Construct the pattern portion of the clause, making sure to |
| 45 | + -- bind all variables. Note that copattern projections are always |
| 46 | + -- visible. |
| 47 | + let |
| 48 | + pat = tel→pats nargs tele ++ |
| 49 | + arg (set-visibility visible field-info) (proj field-name) ∷ |
| 50 | + tel→pats 0 field-tele |
| 51 | + |
| 52 | + -- Construct the body of the clause, making sure to apply all |
| 53 | + -- arguments bound outside the copattern match, and apply the |
| 54 | + -- eta-expanded arguments. We also need to apply all of the |
| 55 | + -- implicit arguments to 'tm'. |
| 56 | + body ← |
| 57 | + in-context (reverse clause-tele) $ |
| 58 | + reduce (def field-name (raise nargs inst-tm v∷ tel→args 0 field-tele)) |
| 59 | + |
| 60 | + -- Construct the final clause. |
| 61 | + pure $ clause clause-tele pat body |
| 62 | + |
| 63 | + -- Define a copattern binding, and predeclare its type if required. |
| 64 | + case declare? of λ where |
| 65 | + true → declare (argN def-name) tp <|> pure tt |
| 66 | + false → pure tt |
| 67 | + |
| 68 | + -- Construct the final copattern. |
| 69 | + define-function def-name clauses |
| 70 | + |
| 71 | +-- Repack a record type. |
| 72 | +-- Will also accept functions into record types like `A → Record`, |
| 73 | +-- and will perform a pointwise repacking. |
| 74 | +repack-record : Term → Term → TC Term |
| 75 | +repack-record tm tp = do |
| 76 | + -- Ensure that codomain is a record type. |
| 77 | + tele , cod-tp ← pi-view <$> reduce tp |
| 78 | + def rec-name params ← pure cod-tp |
| 79 | + where _ → typeError [ "repack-record: codomain of " , termErr tp , " is not a record type." ] |
| 80 | + |
| 81 | + -- Instantiate the term with all telescope arguments to saturate it. |
| 82 | + let inst-tm = apply-tm* tm (tel→args 0 tele) |
| 83 | + |
| 84 | + -- Construct fields for each projection. |
| 85 | + ctor , fields ← get-record-type rec-name |
| 86 | + args ← |
| 87 | + in-context (reverse tele) $ |
| 88 | + for fields λ (arg field-info field-name) → |
| 89 | + argN <$> reduce (def field-name (argN inst-tm ∷ [])) |
| 90 | + |
| 91 | + -- Builld a pointwise repacking. |
| 92 | + pure (tel→lam tele (con ctor args)) |
| 93 | + |
| 94 | +-- Helper for the 'define' macros; Unifies the given goal with the type |
| 95 | +-- of the given function, if it has been defined. If the function has |
| 96 | +-- not been defined, and the first argument is 'false', then an error is |
| 97 | +-- raised. |
| 98 | +type-for : String → Bool → Name → Term → TC ⊤ |
| 99 | +type-for tac decl? fun goal with decl? |
| 100 | +... | true = (unify goal =<< get-type fun) <|> pure tt |
| 101 | +... | false = (unify goal =<< get-type fun) <|> typeError |
| 102 | + [ "define-" , strErr tac , ": the function " , nameErr fun , " should already have been declared." |
| 103 | + ] |
| 104 | + |
| 105 | +-------------------------------------------------------------------------------- |
| 106 | +-- Usage |
| 107 | + |
| 108 | +{- |
| 109 | +Write the following in a module: |
| 110 | +> unquoteDecl copat = declare-copattern copat thing-to-be-expanded |
| 111 | +
|
| 112 | +If you wish to give the binding a type annotation, you can also use |
| 113 | +
|
| 114 | +> copat : Your-type |
| 115 | +> unquoteDecl copat = declare-copattern copat thing-to-be-expanded |
| 116 | +
|
| 117 | +Note that, in this case, the thing-to-be-expanded must have exactly the |
| 118 | +same type as the binding `copat`. All features of non-recursive records |
| 119 | +are supported, including instance fields and fields with implicit |
| 120 | +arguments. |
| 121 | +
|
| 122 | +These macros also allow you to lift functions 'A → some-record-type' |
| 123 | +into copattern definitions. Note that Agda will generate meta for |
| 124 | +implicits before performing quotation, so we need to explicitly |
| 125 | +bind all implicits using a lambda before quotation! |
| 126 | +-} |
| 127 | + |
| 128 | +declare-copattern : ∀ {ℓ} {A : Type ℓ} → Name → A → TC ⊤ |
| 129 | +declare-copattern {A = A} nm x = do |
| 130 | + `x ← quoteTC x |
| 131 | + `A ← quoteTC A |
| 132 | + make-copattern true nm `x `A |
| 133 | + |
| 134 | +define-copattern |
| 135 | + : ∀ {ℓ} (nm : Name) |
| 136 | + → {@(tactic (type-for "copattern" true nm)) A : Type ℓ} |
| 137 | + → A → TC ⊤ |
| 138 | +define-copattern nm {A = A} x = do |
| 139 | + `A ← quoteTC A |
| 140 | + `x ← define-abbrev nm "value" `A =<< quoteTC x |
| 141 | + make-copattern false nm `x `A |
| 142 | + |
| 143 | +{- |
| 144 | +There is a slight caveat with level-polymorphic defintions, as |
| 145 | +they cannot be quoted into any `Type ℓ`. With this in mind, |
| 146 | +we also provide a pair of macros that work over `Typeω` instead. |
| 147 | +-} |
| 148 | + |
| 149 | +declare-copatternω : ∀ {U : Typeω} → Name → U → TC ⊤ |
| 150 | +declare-copatternω nm A = do |
| 151 | + `A ← quoteωTC A |
| 152 | + -- Cannot quote things in type Typeω, but we can infer their type. |
| 153 | + `U ← infer-type `A |
| 154 | + make-copattern true nm `A `U |
| 155 | + |
| 156 | +define-copatternω |
| 157 | + : (nm : Name) {@(tactic (type-for "copatternω" false nm)) U : Typeω} |
| 158 | + → U → TC ⊤ |
| 159 | +define-copatternω nm A = do |
| 160 | + `U ← get-type nm |
| 161 | + `A ← define-abbrev nm "value" `U =<< quoteωTC A |
| 162 | + make-copattern false nm `A `U |
| 163 | + |
| 164 | +{- |
| 165 | +Another common pattern is that two records `r : R p` and `s : R q` may contain |
| 166 | +the same data, but they are parameterized by different values. |
| 167 | +The `define-eta-expansion` macro will automatically construct a function |
| 168 | +`R p → R q` that eta-expands the first record out into a copattern definition. |
| 169 | +-} |
| 170 | + |
| 171 | +define-eta-expansion : Name → TC ⊤ |
| 172 | +define-eta-expansion nm = do |
| 173 | + tp ← reduce =<< infer-type (def nm []) |
| 174 | + let tele , _ = pi-view tp |
| 175 | + let tm = tel→lam tele (var 0 []) |
| 176 | + make-copattern false nm tm tp |
| 177 | + |
| 178 | +-------------------------------------------------------------------------------- |
| 179 | +-- Tests |
| 180 | + |
| 181 | +private module Test where |
| 182 | + -- Record type that uses all interesting features. |
| 183 | + record Record {ℓ} (A : Type ℓ) : Type ℓ where |
| 184 | + no-eta-equality |
| 185 | + constructor mk |
| 186 | + field |
| 187 | + ⦃ c ⦄ : A |
| 188 | + { f } : A → A |
| 189 | + const : ∀ {x} → f x ≡ c |
| 190 | + |
| 191 | + -- Record created via a constructor. |
| 192 | + via-ctor : Record Nat |
| 193 | + via-ctor = mk ⦃ c = 0 ⦄ {f = λ _ → 0} refl |
| 194 | + |
| 195 | + -- Both macros work. |
| 196 | + unquoteDecl copat-decl-via-ctor = declare-copattern copat-decl-via-ctor via-ctor |
| 197 | + |
| 198 | + copat-def-via-ctor : Record Nat |
| 199 | + unquoteDef copat-def-via-ctor = define-copattern copat-def-via-ctor via-ctor |
| 200 | + |
| 201 | + -- Record created by a function. |
| 202 | + module _ (r : Record Nat) where |
| 203 | + open Record r |
| 204 | + via-function : Record Nat |
| 205 | + via-function .c = suc c |
| 206 | + via-function .f = suc ∘ f |
| 207 | + via-function .const = ap suc const |
| 208 | + |
| 209 | + -- Also works when applied to the result of a function. |
| 210 | + unquoteDecl copat-decl-via-function = declare-copattern copat-decl-via-function (via-function via-ctor) |
| 211 | + |
| 212 | + -- Test to see how we handle unused parameters. |
| 213 | + record Unused (n : Nat) : Type where |
| 214 | + field |
| 215 | + actual : Nat |
| 216 | + |
| 217 | + zero-unused-param : Unused 0 |
| 218 | + zero-unused-param = record { actual = 0 } |
| 219 | + |
| 220 | + one-unused-param : ∀ {n} → Unused n |
| 221 | + unquoteDef one-unused-param = declare-copattern one-unused-param zero-unused-param |
| 222 | + -- This is a type error: |
| 223 | + -- unquoteDef one-unused-param = define-copattern one-unused-param zero-unused-param |
| 224 | + -- because the 'define' macro propagates the type of the thing being |
| 225 | + -- defined inwards. |
| 226 | + |
| 227 | + -- Functions into records that are universe polymorphic |
| 228 | + neat : ∀ {ℓ} {A : Type ℓ} → A → Record A |
| 229 | + neat a .Record.c = a |
| 230 | + neat a .Record.f _ = a |
| 231 | + neat a .Record.const = refl |
| 232 | + |
| 233 | + -- Implicit insertion is correct for the define- macro, since the type |
| 234 | + -- of the function is given. |
| 235 | + cool : ∀ {ℓ} {A : Type ℓ} → A → Record A |
| 236 | + unquoteDef cool = define-copatternω cool neat |
| 237 | + |
| 238 | + -- Eta-expanders |
| 239 | + expander : ∀ {m n : Nat} → Unused m → Unused n |
| 240 | + unquoteDef expander = define-eta-expansion expander |
| 241 | + |
| 242 | + -- Raises a type error: the function should have a declaration. |
| 243 | + -- unquoteDecl uncool = define-copatternω uncool neat |
0 commit comments