├── .gitignore ├── README.md ├── ataca.agda-lib ├── old ├── Auto1.agda ├── Auto2.agda └── Auto3.agda └── src └── Ataca ├── Core.agda ├── Demo.agda ├── Tactics.agda ├── Tactics ├── Admit.agda ├── Assumption.agda ├── BasicTactics.agda ├── Constructor.agda ├── Destruct.agda ├── Exact.agda ├── Intro.agda ├── MiniAuto.agda └── Refine.agda ├── Tests.agda └── Utils.agda /.gitignore: -------------------------------------------------------------------------------- 1 | agda-ffi/dist 2 | *.agdai 3 | MAlonzo 4 | *.prof 5 | *.treeless 6 | *.hi 7 | *.o 8 | *.agda# 9 | *.agda~ 10 | .#*.agda 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ataca: A TACtic library for Agda 2 | ================================ 3 | 4 | This library provides an interface for writing tactics for Agda. It 5 | also provides several basic tactics and tactic combinators. 6 | 7 | Currently the following tactics are supported: 8 | 9 | * exact: solve a goal with an explicitly given value 10 | * admit: solve a goal by creating a new postulate 11 | * assumption: search the context for a variable that fits the goal 12 | * intro: refine the goal by introducing a lambda 13 | * intros: refine the goal by introducing as many lambdas as possible 14 | * introAbsurd: solve the goal with an absurd lambda 15 | * introConstructor: refine the goal by introducing a constructor that fits the hole 16 | * introConstructors: refine the goal by repeatedly introducing constructors that fit the (sub)goals 17 | * refine: refine the goal with a given term applied to some arguments 18 | * mini-auto: repeatedly apply assumption, intro, and introConstructor 19 | * mini-auto-with: repeatedly apply assumption, intro, introConstructor, and refine with terms from a given list of hints 20 | * destruct: case split on the given variable (using a pattern-matching lambda) 21 | 22 | The library is currently still work in progress and anything is 23 | subject to change at any time. -------------------------------------------------------------------------------- /ataca.agda-lib: -------------------------------------------------------------------------------- 1 | name: ataca 2 | include: src 3 | depend: standard-library 4 | -------------------------------------------------------------------------------- /old/Auto1.agda: -------------------------------------------------------------------------------- 1 | open import Prelude hiding (_>>=_; _>>_; abs) renaming (_>>=′_ to _>>=_; _>>′_ to _>>_) 2 | open import Container.List 3 | open import Container.Traversable 4 | open import Tactic.Reflection 5 | open import Tactic.Deriving.Eq 6 | 7 | Cont = Term → TC ⊤ 8 | 9 | done : Cont 10 | done _ = return _ 11 | 12 | Tac = Cont → Cont 13 | 14 | try : Tac 15 | try cont goal = cont goal <|> done goal 16 | 17 | _and-then_ : Tac → Tac → Tac 18 | (tac₁ and-then tac₂) ret goal = tac₁ (tac₂ ret) goal <|> tac₂ ret goal 19 | 20 | repeat : Nat → Tac → Tac 21 | repeat zero tac ret = ret 22 | repeat (suc k) tac ret goal = tac (repeat k tac ret) goal <|> ret goal 23 | 24 | assumption' : Tac 25 | assumption' ret goal = do 26 | k ← length <$> getContext 27 | choice $ map tryVar (from 0 to k) 28 | where 29 | tryVar : Nat → TC ⊤ 30 | tryVar i = unify (var i []) goal 31 | 32 | macro 33 | assumption : Term → TC ⊤ 34 | assumption = assumption' done 35 | 36 | test₁ : Nat → Bool → Nat 37 | test₁ x y = assumption 38 | 39 | test₂ : Nat → Bool → Bool 40 | test₂ x y = assumption 41 | 42 | intro' : Cont → Term → TC ⊤ 43 | intro' ret goal@(meta _ _) = do 44 | t ← inferType goal 45 | pi a b ← reduce t 46 | where t → typeError $ strErr "Not a function type: " ∷ termErr t ∷ [] 47 | body ← extendContext a $ newMeta (unAbs b) 48 | let v = getVisibility a 49 | unify (lam v (body <$ b)) goal 50 | extendContext a $ ret body 51 | intro' ret goal = typeError $ strErr "Goal already solved: " ∷ termErr goal ∷ [] 52 | 53 | macro 54 | intro : Term → TC ⊤ 55 | intro = intro' done 56 | 57 | intros' : Nat → Tac 58 | intros' k = repeat k intro' 59 | 60 | macro 61 | intros : Term → TC ⊤ 62 | intros = intros' 100 done 63 | 64 | test₃ : Nat → Bool → ⊤ 65 | test₃ = intros 66 | 67 | mini-auto' : Tac 68 | mini-auto' = repeat 100 (assumption' and-then intro') 69 | 70 | macro 71 | mini-auto : Tactic 72 | mini-auto = mini-auto' done 73 | 74 | test₄ : Nat → Bool → Nat 75 | test₄ = mini-auto 76 | -------------------------------------------------------------------------------- /old/Auto2.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K -v tac:10 #-} 2 | 3 | open import Prelude hiding (_>>=_; _>>_; abs) renaming (_>>=′_ to _>>=_; _>>′_ to _>>_) 4 | open import Container.List 5 | open import Container.Traversable 6 | open import Tactic.Reflection 7 | open import Tactic.Deriving.Eq 8 | 9 | void : ∀ {ℓ} {A : Set ℓ} → TC A → TC ⊤ 10 | void m = m >> return _ 11 | 12 | record Goal : Set where 13 | field 14 | theGoal : Term 15 | goalCtx : List (Arg Type) 16 | open Goal 17 | 18 | Tac = Term → TC (List Goal) 19 | 20 | runTac : Tac → Tactic 21 | runTac tac = void ∘ tac 22 | 23 | macro 24 | run : Tac → Tactic 25 | run tac = runTac tac 26 | 27 | applyTac : Tac → Goal → TC (List Goal) 28 | applyTac tac goal = inContext (goal .goalCtx) $ do 29 | `tac ← quoteTC tac 30 | goalType ← inferType $ goal .theGoal 31 | debugPrint "tac.apply" 10 (strErr "Running tactic: " ∷ termErr `tac ∷ []) 32 | debugPrint "tac.apply" 10 (strErr "Goal: " ∷ termErr (goal .theGoal) ∷ strErr ":" ∷ termErr goalType ∷ []) 33 | debugPrint "tac.apply" 10 (strErr "Context: " ∷ map (termErr ∘ unArg) (goal .goalCtx)) 34 | tac (goal .theGoal) 35 | 36 | goalErr : Goal → TC (List ErrorPart) 37 | goalErr goal = inContext (goal .goalCtx) $ do 38 | goalType ← inferType $ goal .theGoal 39 | return (termErr (goal .theGoal) ∷ strErr ":" ∷ termErr goalType ∷ []) 40 | 41 | infixl 10 _and-then_ 42 | _and-then_ : Tac → Tac → Tac 43 | (tac₁ and-then tac₂) goal = do 44 | subgoals ← tac₁ goal 45 | concat <$> traverse (applyTac tac₂) subgoals 46 | 47 | infixl 10 _or-else_ 48 | _or-else_ : Tac → Tac → Tac 49 | (tac₁ or-else tac₂) goal = tac₁ goal <|> tac₂ goal 50 | 51 | pass : Tac 52 | pass goal = getContext >>= λ ctx → return $ singleton λ where 53 | .theGoal → goal 54 | .goalCtx → ctx 55 | 56 | try : Tac → Tac 57 | try tac = tac or-else pass 58 | 59 | now : Tac → Tac 60 | now tac goal = do 61 | [] ← tac goal 62 | where subgoals → do 63 | unsolveds ← traverse goalErr subgoals 64 | typeError $ strErr "Unsolved subgoals: " ∷ concat unsolveds 65 | return [] 66 | 67 | repeat : Nat → Tac → Tac 68 | repeat zero tac = pass 69 | repeat (suc k) tac = tac and-then repeat k tac 70 | 71 | alreadySolved : Tac 72 | alreadySolved goal = reduce goal >>= λ where 73 | goal@(meta _ _) → do 74 | goalType ← inferType goal 75 | typeError $ strErr "Unsolved subgoal: " ∷ termErr goal ∷ strErr ":" ∷ termErr goalType ∷ [] 76 | _ → return [] 77 | 78 | unlessSolved : Tac → Tac 79 | unlessSolved tac = alreadySolved or-else tac 80 | 81 | {- 82 | {-# TERMINATING #-} 83 | allMetas : Term → TC (List Goal) 84 | allMetas (var x args) = concat <$> traverse (allMetas ∘ unArg) args 85 | allMetas (con c args) = concat <$> traverse (allMetas ∘ unArg) args 86 | allMetas (def f args) = concat <$> traverse (allMetas ∘ unArg) args 87 | allMetas (lam v (abs _ t)) = extendContext (arg (arg-info v relevant) unknown) (allMetas t) 88 | allMetas (pat-lam cs args) = {!!} 89 | allMetas (pi a b) = ⦇ allMetas (unArg a) ++ {!extendContext!} ⦈ 90 | allMetas (agda-sort s) = {!s!} 91 | allMetas (lit l) = return [] 92 | allMetas (meta x args) = {!!} 93 | allMetas unknown = return [] 94 | 95 | give' : Term → Tac 96 | give' u goal = do 97 | unify u goal 98 | {!!} 99 | -} 100 | 101 | assumption' : Tac 102 | assumption' = unlessSolved λ goal → do 103 | k ← length <$> getContext 104 | let tryVar : Nat → TC ⊤ 105 | tryVar i = unify (var i []) goal 106 | choice $ map tryVar (from 0 to (k - 1)) 107 | return [] 108 | 109 | macro 110 | assumption : Tactic 111 | assumption = runTac assumption' 112 | 113 | 114 | intro' : Tac 115 | intro' = unlessSolved λ goal → do 116 | pi a b ← reduce =<< inferType goal 117 | where t → typeError $ strErr "Not a function type: " ∷ termErr t ∷ [] 118 | body ← extendContext a $ newMeta (unAbs b) 119 | let v = getVisibility a 120 | unify (lam v (body <$ b)) goal 121 | extendContext a $ pass body 122 | 123 | macro 124 | intro : Tactic 125 | intro = runTac intro' 126 | 127 | intros' : Nat → Tac 128 | intros' k = repeat k intro' 129 | 130 | macro 131 | intros : Tactic 132 | intros = runTac $ intros' 10 133 | 134 | 135 | choice' : ∀ {a b} {F : Set a → Set b} {A : Set a} {{_ : Alternative F}} 136 | → List (F A) → F A 137 | choice' [] = empty 138 | choice' [ f ] = f 139 | choice' (f ∷ fs) = f <|> choice' fs 140 | 141 | {-# TERMINATING #-} 142 | constr' : Tac 143 | constr' goal = do 144 | def d us ← reduce =<< inferType goal 145 | where t → errorNotData t 146 | debugPrint "tac.constr" 10 (strErr "Searching constructor for" ∷ termErr (def d []) ∷ []) 147 | cons , #pars ← getDefinition d >>= λ where 148 | (data-type #pars cons) → return $ cons ,′ #pars 149 | (record-type c fields) → return $ singleton c , length us 150 | _ → errorNotData (def d us) 151 | debugPrint "tac.constr" 10 (strErr "Constructors: " ∷ map (λ c → termErr (con c [])) cons) 152 | debugPrint "tac.constr" 20 (strErr "Number of parameters: " ∷ strErr (show #pars) ∷ []) 153 | let pars = take #pars us 154 | choice' (map (λ c → tryConstr pars c goal) cons) 155 | 156 | where 157 | loop : Type → (List (Arg Term) → Term) → List Goal → Tac 158 | loop t hd subgoals goal = case t of λ where 159 | (pi a b) → do 160 | x ← newMeta (unArg a) 161 | t' ← reduce (lam visible b `$ x) 162 | newgoal ← pass x 163 | loop t' (hd ∘ ((x <$ a) ∷_)) (newgoal ++ subgoals) goal 164 | (def _ _) → do 165 | debugPrint "tac.constr" 10 (strErr "Trying solution: " ∷ termErr (hd []) ∷ []) 166 | `hd ← quoteTC (hd []) 167 | debugPrint "tac.constr" 30 (strErr "Trying solution: " ∷ termErr `hd ∷ []) 168 | debugPrint "tac.constr" 10 (strErr "Subgoals: " ∷ map (λ goal → termErr (goal .theGoal)) subgoals) 169 | unify (hd []) goal 170 | return subgoals 171 | t → typeError $ strErr "IMPOSSIBLE! Should be pi or def: " ∷ termErr t ∷ [] 172 | 173 | applyToPars : List (Arg Term) → Type → TC Type 174 | applyToPars [] t = return t 175 | applyToPars (u ∷ us) t@(pi a b) = do 176 | debugPrint "tac.constr.pars" 30 (strErr "Applying to parameters: " ∷ termErr t ∷ []) 177 | just safe-u ← return $ maybeSafe (unArg u) 178 | where nothing → typeError $ strErr "Cannot substitute unsafe parameter: " ∷ termErr (unArg u) ∷ [] 179 | let t' = substTerm (safe-u ∷ []) (unAbs b) 180 | applyToPars us t' 181 | applyToPars _ t = typeError $ strErr "IMPOSSIBLE! Should be pi: " ∷ termErr t ∷ [] 182 | 183 | setHidden : {A : Set} → Arg A → Arg A 184 | setHidden (arg (arg-info _ r) x) = arg (arg-info hidden r) x 185 | 186 | tryConstr : List (Arg Term) → Name → Tac 187 | tryConstr pars c goal = do 188 | t ← getType c 189 | debugPrint "tac.constr" 10 (strErr "Type of constructor" ∷ termErr (con c []) ∷ strErr ":" ∷ termErr t ∷ []) 190 | t ← applyToPars pars t 191 | debugPrint "tac.constr" 10 (strErr " => applied to parameters:" ∷ termErr t ∷ []) 192 | let implicitPars = map setHidden pars 193 | loop t (λ args → con c (implicitPars ++ args)) [] goal 194 | 195 | errorNotData : {A : Set} → Term → TC A 196 | errorNotData t = typeError $ strErr "Not a data/record type: " ∷ termErr t ∷ [] 197 | 198 | 199 | macro 200 | constr : Tactic 201 | constr = runTac constr' 202 | 203 | constrs : Tactic 204 | constrs = runTac (repeat 10 constr') 205 | 206 | mini-auto' : Tac 207 | mini-auto' = repeat 10 (assumption' or-else intro' or-else constr') 208 | 209 | macro 210 | mini-auto : Tactic 211 | mini-auto = runTac mini-auto' 212 | 213 | 214 | test₁ : Nat → Bool → Nat 215 | test₁ x y = assumption 216 | 217 | test₂ : Nat → Bool → Bool 218 | test₂ x y = assumption 219 | 220 | test₄ : Nat → Bool → Nat 221 | test₄ = mini-auto 222 | 223 | test₅ : Bool 224 | test₅ = constr 225 | 226 | test₆ : Nat 227 | test₆ = constr 228 | 229 | test₇ : _≡_ {A = Bool} true true 230 | test₇ = constr 231 | 232 | test₈ : Vec Nat 0 233 | test₈ = constrs 234 | 235 | test₉ : Vec Bool 3 236 | test₉ = constrs 237 | 238 | test₁₀ : {A : Set} → A → Vec A 5 239 | test₁₀ = mini-auto 240 | 241 | data DecVec (n : Nat) : Nat → Set where 242 | [] : DecVec n zero 243 | cons : ∀ {k} → (m : Nat) → m < n → DecVec m k → DecVec n (suc k) 244 | 245 | test₁₁ : DecVec 4 3 246 | test₁₁ = mini-auto 247 | 248 | test₁₂ : 5 ∈ from 2 to 7 249 | test₁₂ = {!mini-auto!} 250 | -------------------------------------------------------------------------------- /old/Auto3.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K -v tac.refine:50 #-} 2 | 3 | open import Prelude hiding (_>>=_; _>>_; abs) renaming (_>>=′_ to _>>=_; _>>′_ to _>>_) 4 | open import Container.List 5 | open import Container.Traversable 6 | open import Tactic.Reflection 7 | open import Tactic.Deriving.Eq 8 | 9 | void : ∀ {ℓ} {A : Set ℓ} → TC A → TC ⊤ 10 | void m = m >> return _ 11 | 12 | choice' : ∀ {a b} {F : Set a → Set b} {A : Set a} {{_ : Alternative F}} 13 | → List (F A) → F A 14 | choice' [] = empty 15 | choice' [ f ] = f 16 | choice' (f ∷ fs) = f <|> choice' fs 17 | 18 | 19 | record Goal : Set where 20 | field 21 | theGoal : Term 22 | goalCtx : List (Arg Type) 23 | open Goal 24 | 25 | Tac = Term → TC (List Goal) 26 | 27 | runTac : Tac → Tactic 28 | runTac tac = void ∘ tac 29 | 30 | macro 31 | run : Tac → Tactic 32 | run tac = runTac tac 33 | 34 | applyTac : Tac → Goal → TC (List Goal) 35 | applyTac tac goal = inContext (goal .goalCtx) $ do 36 | `tac ← quoteTC tac 37 | goalType ← inferType $ goal .theGoal 38 | debugPrint "tac.apply" 10 (strErr "Running tactic: " ∷ termErr `tac ∷ []) 39 | debugPrint "tac.apply" 10 (strErr "Goal: " ∷ termErr (goal .theGoal) ∷ strErr ":" ∷ termErr goalType ∷ []) 40 | debugPrint "tac.apply" 10 (strErr "Context: " ∷ map (termErr ∘ unArg) (goal .goalCtx)) 41 | tac (goal .theGoal) 42 | 43 | goalErr : Goal → TC (List ErrorPart) 44 | goalErr goal = inContext (goal .goalCtx) $ do 45 | goalType ← inferType $ goal .theGoal 46 | return (termErr (goal .theGoal) ∷ strErr ":" ∷ termErr goalType ∷ []) 47 | 48 | 49 | infixl 10 _and-then_ 50 | _and-then_ : Tac → Tac → Tac 51 | (tac₁ and-then tac₂) goal = do 52 | subgoals ← tac₁ goal 53 | concat <$> traverse (applyTac tac₂) subgoals 54 | 55 | infixl 10 _or-else_ 56 | _or-else_ : Tac → Tac → Tac 57 | (tac₁ or-else tac₂) goal = tac₁ goal <|> tac₂ goal 58 | 59 | pass : Tac 60 | pass goal = getContext >>= λ ctx → return $ singleton λ where 61 | .theGoal → goal 62 | .goalCtx → ctx 63 | 64 | try : Tac → Tac 65 | try tac = tac or-else pass 66 | 67 | now : Tac → Tac 68 | now tac goal = do 69 | [] ← tac goal 70 | where subgoals → do 71 | unsolveds ← traverse goalErr subgoals 72 | typeError $ strErr "Unsolved subgoals: " ∷ concat unsolveds 73 | return [] 74 | 75 | repeat : Nat → Tac → Tac 76 | repeat zero tac = pass 77 | repeat (suc k) tac = tac and-then repeat k tac 78 | 79 | 80 | alreadySolved : Tac 81 | alreadySolved goal = reduce goal >>= λ where 82 | goal@(meta _ _) → do 83 | goalType ← inferType goal 84 | typeError $ strErr "Unsolved subgoal: " ∷ termErr goal ∷ strErr ":" ∷ termErr goalType ∷ [] 85 | _ → return [] 86 | 87 | unlessSolved : Tac → Tac 88 | unlessSolved tac = alreadySolved or-else tac 89 | 90 | MultiTac = Term → TC (List (Bool × Tac)) 91 | 92 | toMulti : Bool → Tac → MultiTac 93 | toMulti b tac _ = return $ singleton (b , tac) 94 | 95 | fromMulti : MultiTac → Tac 96 | fromMulti mtac goal = tryTacs =<< mtac goal 97 | where 98 | tryTacs : List (Bool × Tac) → TC (List Goal) 99 | tryTacs tacs = choice' (for tacs (λ { (_ , tac) → tac goal })) 100 | 101 | runMultiTac : MultiTac → Tactic 102 | runMultiTac = runTac ∘ fromMulti 103 | 104 | repeatMulti : Nat → MultiTac → Tac 105 | repeatMulti 0 mtac goal = pass goal 106 | repeatMulti (suc k) mtac goal = do 107 | tacs ← mtac goal 108 | `tacs ← traverse (quoteTC ∘ snd) tacs 109 | debugPrint "tac.repeat" 10 (strErr "Tactic menu: " ∷ map termErr `tacs) 110 | tryTacs tacs goal 111 | where 112 | tryTacs : List (Bool × Tac) → Tac 113 | tryTacs [] goal = typeError $ strErr "Give at least one tactic to repeat" ∷ [] 114 | --tryTacs ((_ , tac) ∷ [] ) goal = tac goal 115 | tryTacs ((true , tac) ∷ tacs) goal = do 116 | `tac ← quoteTC tac 117 | debugPrint "tac.repeat" 10 (strErr "Trying tactic" ∷ termErr `tac ∷ []) 118 | just subgoals ← maybeA $ tac goal 119 | where nothing → tryTacs tacs goal 120 | debugPrint "tac.repeat" 10 (strErr "Tactic" ∷ termErr `tac ∷ strErr "was succesful!" ∷ []) 121 | `subgoals ← concat <$> traverse goalErr subgoals 122 | -- TODO: this throws errors while printing! 123 | --debugPrint "tac.repeat" 10 (strErr "Subgoals:" ∷ `subgoals) 124 | concat <$> traverse (applyTac (repeatMulti k mtac)) subgoals 125 | tryTacs ((false , tac) ∷ tacs) = 126 | ((tac and-then repeatMulti k mtac) or-else tryTacs tacs) 127 | 128 | _or-else-multi_ : MultiTac → MultiTac → MultiTac 129 | (mtac₁ or-else-multi mtac₂) goal = ⦇ mtac₁ goal ++ mtac₂ goal ⦈ 130 | 131 | exact' : Term → Tac 132 | exact' u goal = unify u goal >> return [] 133 | 134 | macro 135 | exact : Term → Tactic 136 | exact u = runTac $ exact' u 137 | 138 | 139 | assumption' : Tac 140 | assumption' = unlessSolved λ goal → do 141 | goalType ← inferType goal 142 | debugPrint "tac.constr" 10 (strErr "Trying assumption on" ∷ termErr goalType ∷ []) 143 | k ← length <$> getContext 144 | let tryVar : Nat → TC ⊤ 145 | tryVar i = unify (var i []) goal 146 | choice $ map tryVar (from 0 to (k - 1)) 147 | return [] 148 | 149 | macro 150 | assumption : Tactic 151 | assumption = runTac assumption' 152 | 153 | 154 | intro' : Tac 155 | intro' = unlessSolved λ goal → do 156 | goalType ← inferType goal 157 | debugPrint "tac.constr" 10 (strErr "Trying intro on" ∷ termErr goalType ∷ []) 158 | pi a b ← reduce goalType 159 | where t → typeError $ strErr "Not a function type: " ∷ termErr t ∷ [] 160 | body ← extendContext a $ newMeta (unAbs b) 161 | let v = getVisibility a 162 | unify (lam v (body <$ b)) goal 163 | extendContext a $ pass body 164 | 165 | macro 166 | intro : Tactic 167 | intro = runTac intro' 168 | 169 | intros' : Nat → Tac 170 | intros' k = repeat k intro' 171 | 172 | macro 173 | intros : Tactic 174 | intros = runTac $ intros' 10 175 | 176 | {-# TERMINATING #-} 177 | constr' : MultiTac 178 | constr' goal = do 179 | goalType ← inferType goal 180 | debugPrint "tac.constr" 10 (strErr "Searching constructor for" ∷ termErr goalType ∷ []) 181 | def d us ← reduce goalType 182 | where t → do 183 | debugPrint "tac.constr" 10 $ strErr "Not a data/record type: " ∷ termErr t ∷ [] 184 | return [] 185 | cons , #pars ← getDefinition d >>= λ where 186 | (data-type #pars cons) → return $ cons ,′ #pars 187 | (record-type c fields) → return $ singleton c , length us 188 | _ → do 189 | debugPrint "tac.constr" 10 $ strErr "Not a data/record type: " ∷ termErr (def d us) ∷ [] 190 | return $ [] , 0 191 | debugPrint "tac.constr" 10 (strErr "Constructors: " ∷ map (λ c → termErr (con c [])) cons) 192 | debugPrint "tac.constr" 20 (strErr "Number of parameters: " ∷ strErr (show #pars) ∷ []) 193 | let pars = take #pars us 194 | return $ map (λ c → false , tryConstr pars c) cons 195 | 196 | where 197 | loop : Type → (List (Arg Term) → Term) → List Goal → Tac 198 | loop t hd subgoals goal = case t of λ where 199 | (pi a b) → do 200 | x ← newMeta (unArg a) 201 | t' ← reduce (lam visible b `$ x) 202 | newgoal ← pass x 203 | loop t' (hd ∘ ((x <$ a) ∷_)) (newgoal ++ subgoals) goal 204 | (def _ _) → do 205 | debugPrint "tac.constr" 10 (strErr "Trying solution: " ∷ termErr (hd []) ∷ []) 206 | `hd ← quoteTC (hd []) 207 | debugPrint "tac.constr" 30 (strErr "Trying solution: " ∷ termErr `hd ∷ []) 208 | debugPrint "tac.constr" 10 (strErr "Subgoals: " ∷ map (λ goal → termErr (goal .theGoal)) subgoals) 209 | unify (hd []) goal 210 | return subgoals 211 | t → typeError $ strErr "IMPOSSIBLE! Should be pi or def: " ∷ termErr t ∷ [] 212 | 213 | applyToPars : List (Arg Term) → Type → TC Type 214 | applyToPars [] t = return t 215 | applyToPars (u ∷ us) t@(pi a b) = do 216 | debugPrint "tac.constr.pars" 30 (strErr "Applying to parameters: " ∷ termErr t ∷ []) 217 | just safe-u ← return $ maybeSafe (unArg u) 218 | where nothing → typeError $ strErr "Cannot substitute unsafe parameter: " ∷ termErr (unArg u) ∷ [] 219 | let t' = substTerm (safe-u ∷ []) (unAbs b) 220 | applyToPars us t' 221 | applyToPars _ t = typeError $ strErr "IMPOSSIBLE! Should be pi: " ∷ termErr t ∷ [] 222 | 223 | setHidden : {A : Set} → Arg A → Arg A 224 | setHidden (arg (arg-info _ r) x) = arg (arg-info hidden r) x 225 | 226 | tryConstr : List (Arg Term) → Name → Tac 227 | tryConstr pars c goal = do 228 | t ← getType c 229 | debugPrint "tac.constr" 10 (strErr "Type of constructor" ∷ termErr (con c []) ∷ strErr ":" ∷ termErr t ∷ []) 230 | t ← applyToPars pars t 231 | debugPrint "tac.constr" 10 (strErr " => applied to parameters:" ∷ termErr t ∷ []) 232 | let implicitPars = map setHidden pars 233 | loop t (λ args → con c (implicitPars ++ args)) [] goal 234 | 235 | 236 | 237 | macro 238 | constr : Tactic 239 | constr = runMultiTac constr' 240 | 241 | constrs : Tactic 242 | constrs = runTac (repeatMulti 10 constr') 243 | 244 | refineAux' : Nat → Type → (List (Arg Term) → Term) → List Goal → Tac 245 | refineAux' zero t hd subgoals goal = do 246 | debugPrint "tac.refine" 10 $ strErr "Trying solution: " ∷ termErr (hd []) ∷ [] 247 | debugPrint "tac.refine" 30 $ strErr " type of head" ∷ termErr t ∷ [] 248 | unify (hd []) goal 249 | return subgoals 250 | refineAux' (suc n) t hd subgoals goal = do 251 | debugPrint "tac.refine" 30 $ strErr " applying" ∷ termErr (hd []) ∷ strErr "to" ∷ strErr (show {A = Nat} (suc n)) ∷ strErr "more arguments..." ∷ [] 252 | debugPrint "tac.refine" 30 $ strErr " type of head" ∷ termErr t ∷ [] 253 | `t ← normalise =<< quoteTC t 254 | debugPrint "tac.refine" 50 $ strErr " raw type" ∷ termErr `t ∷ [] 255 | pi (arg ai a) b ← reduce t 256 | where t → do 257 | debugPrint "tac.refine" 10 $ strErr "Not a pi type: " ∷ termErr t ∷ [] 258 | typeError $ strErr "Should be a pi type: " ∷ termErr t ∷ [] 259 | debugPrint "tac.refine" 30 $ strErr "Creating new meta of type " ∷ termErr a ∷ [] 260 | ctx ← getContext 261 | debugPrint "tac.refine" 30 $ strErr "Current context " ∷ map (termErr ∘ unArg) ctx 262 | x ← newMeta a 263 | debugPrint "tac.refine" 30 $ strErr "Created new meta: " ∷ termErr x ∷ [] 264 | x ← reduce x 265 | debugPrint "tac.refine" 30 $ strErr "Reduced meta: " ∷ termErr x ∷ [] 266 | newgoal ← pass x 267 | debugPrint "tac.refine" 30 $ strErr "Created new subgoal." ∷ [] 268 | just safe-x ← return $ maybeSafe x 269 | where nothing → do 270 | debugPrint "tac.refine" 10 $ strErr "Unsafe argument: " ∷ termErr x ∷ [] 271 | typeError $ strErr "Cannot substitute unsafe argument: " ∷ termErr x ∷ [] 272 | debugPrint "tac.refine" 30 $ strErr "Codomain (before substituting):" ∷ termErr (unAbs b) ∷ [] 273 | let t' = substTerm (safe-x ∷ []) (unAbs b) 274 | debugPrint "tac.refine" 30 $ strErr "Codomain (after substituting):" ∷ termErr t' ∷ [] 275 | refineAux' n t' (hd ∘ (arg ai x ∷_)) (newgoal ++ subgoals) goal 276 | 277 | refineN' : Nat → Name → Tac 278 | refineN' n f goal = do 279 | debugPrint "tac.refine" 10 $ strErr "Trying to refine goal with" ∷ termErr (def f []) ∷ strErr "applied to" ∷ strErr (show n) ∷ strErr "arguments" ∷ [] 280 | t ← getType f 281 | debugPrint "tac.refine" 10 $ strErr " type of head" ∷ termErr t ∷ [] 282 | refineAux' n t (def f) [] goal 283 | 284 | macro 285 | refineN : Nat → Name → Tactic 286 | refineN n f = runTac $ refineN' n f 287 | 288 | refine' : Name → MultiTac 289 | refine' f goal = do 290 | debugPrint "tac.refine" 10 $ strErr "Trying to refine goal with" ∷ termErr (def f []) ∷ [] 291 | return (map (λ n → true , refineN' n f) (from 0 to 10)) 292 | 293 | macro 294 | refine : Name → Tactic 295 | refine f = runMultiTac $ refine' f 296 | 297 | mini-auto' : Tac 298 | mini-auto' = repeatMulti 10 ((toMulti true assumption') or-else-multi ((toMulti true intro') or-else-multi constr')) 299 | 300 | macro 301 | mini-auto : Tactic 302 | mini-auto = runTac mini-auto' 303 | 304 | test₁ : Nat → Bool → Nat 305 | test₁ x y = x 306 | 307 | test₂ : Nat → Bool → Bool 308 | test₂ x y = y 309 | 310 | test₄ : Nat → Bool → Nat 311 | test₄ = λ n b → n 312 | 313 | test₅ : Bool 314 | test₅ = false 315 | 316 | test₆ : Nat 317 | test₆ = zero 318 | 319 | test₇ : _≡_ {A = Bool} true true 320 | test₇ = refl 321 | 322 | test₈ : Vec Nat 0 323 | test₈ = [] 324 | 325 | test₉ : Vec Bool 3 326 | test₉ = false ∷ false ∷ false ∷ [] 327 | 328 | test₁₀ : {A : Set} → A → Vec A 5 329 | test₁₀ = λ z → z ∷ z ∷ z ∷ z ∷ z ∷ [] 330 | 331 | data DecrVec (n : Nat) : Nat → Set where 332 | [] : DecrVec n zero 333 | cons : ∀ {k} → (m : Nat) → m < n → DecrVec m k → DecrVec n (suc k) 334 | 335 | test₁₁ : DecrVec 4 3 336 | test₁₁ = cons 2 (diff! 1) (cons 1 (diff! zero) (cons zero (diff! zero) [])) 337 | 338 | test₁₂ : 5 ∈ from 2 to 7 339 | test₁₂ = suc (suc (suc zero!)) 340 | 341 | data Nat' : Set where 342 | suc : Nat' → Nat' 343 | zero : Nat' 344 | 345 | testNat' : Nat' 346 | testNat' = suc (suc (suc (suc (suc (suc (suc (suc (suc (suc ?))))))))) 347 | 348 | 349 | {- 350 | postulate 351 | emptyList : (A : Set) → List A 352 | --emptyList A = [] 353 | 354 | postulate 355 | MyList : (A : Set) → Set 356 | my-map : (A : Set) → Char → MyList String → MyList A 357 | --my-map A f xs = map f xs 358 | 359 | test₁₃ : (Nat → Bool) → MyList Bool 360 | test₁₃ f = {!refineN 3 my-map!} 361 | -} 362 | -------------------------------------------------------------------------------- /src/Ataca/Core.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Ataca.Utils 3 | 4 | module Ataca.Core where 5 | 6 | record TacCore : Setω where 7 | field 8 | Tac : (A : Set ℓ) → Set ℓ 9 | 10 | -- run tactic as Agda macro 11 | runTac : Tac ⊤ → Term → TC ⊤ 12 | 13 | -- instances 14 | instance 15 | {{functorTac}} : Functor (Tac {ℓ}) 16 | {{functorLiftTac}} : FunctorLift Tac ℓ A 17 | {{applicativeTac}} : Applicative (Tac {ℓ}) 18 | {{monadTac}} : Monad (Tac {ℓ}) 19 | {{applicativeZeroTac}} : ApplicativeZero (Tac {ℓ}) 20 | {{alternativeTac}} : Alternative (Tac {ℓ}) 21 | 22 | -- goal manipulation 23 | getHole : Tac Term 24 | setHole : Term → Tac ⊤ 25 | getCtx : Tac Telescope 26 | addCtx : Arg Type → Tac ⊤ 27 | 28 | -- lifting TC actions 29 | liftTC : TC A → Tac A -- backtrack on failure 30 | liftTC! : TC A → Tac A -- abort on failure 31 | 32 | -- creating and destroying subgoals 33 | fork : Tac Bool 34 | skip : Tac A 35 | 36 | macro 37 | run : Tac ⊤ → Term → TC ⊤ 38 | run tac = runTac tac 39 | 40 | private 41 | record Goal : Set where 42 | constructor mkGoal 43 | field 44 | theHole : Term 45 | goalCtx : Telescope 46 | open Goal 47 | 48 | {-# NO_POSITIVITY_CHECK #-} 49 | data Tac (A : Set ℓ) : Set ℓ where 50 | done : A → Tac A 51 | step : TC (Tac A) → Tac A 52 | goalTac : (Goal → Tac A × Goal) → Tac A 53 | failTac : Tac A 54 | chooseTac : Tac A → Tac A → Tac A 55 | skipTac : Tac A 56 | forkTac : Tac A → Tac A → Tac A 57 | 58 | private 59 | {-# TERMINATING #-} 60 | runTac' : Tac A → Goal 61 | → TC (Maybe (List (A × Goal))) 62 | → TC (Maybe (List (A × Goal))) 63 | runTac' (done x) goal cont = fmap ((x , goal) ∷_) <$> cont 64 | runTac' (step mtac) goal cont = do 65 | tac ← mtac 66 | runTac' tac goal cont 67 | runTac' (goalTac f) goal cont = 68 | let tac' , goal' = f goal 69 | in runTac' tac' goal' cont 70 | runTac' failTac goal cont = return nothing 71 | runTac' (chooseTac tac₁ tac₂) goal cont = do 72 | x ← TC.runSpeculative $ do 73 | just subgoals ← runTac' tac₁ goal cont 74 | where nothing → return $ nothing , false 75 | return $ just subgoals , true 76 | case x of λ where 77 | nothing → runTac' tac₂ goal cont 78 | (just subgoals) → return $ just subgoals 79 | runTac' skipTac goal cont = cont 80 | runTac' (forkTac tac₁ tac₂) goal cont = 81 | runTac' tac₁ goal (runTac' tac₂ goal cont) 82 | 83 | runTac : Tac A → Goal → TC (Maybe (List (A × Goal))) 84 | runTac tac goal = runTac' tac goal (return $ just []) 85 | 86 | toMacro : Tac ⊤ → Term → TC ⊤ 87 | toMacro tac hole = do 88 | `tac ← TC.quoteTC tac 89 | holeType ← TC.inferType hole 90 | TC.debugPrint "tac" 5 $ 91 | strErr "Running tactic" ∷ termErr `tac ∷ 92 | strErr "on hole" ∷ termErr hole ∷ 93 | strErr ":" ∷ termErr holeType ∷ [] 94 | just _ ← runTac tac $ mkGoal hole [] 95 | where nothing → TC.typeError (strErr "Tactic" ∷ termErr `tac ∷ strErr "failed!" ∷ []) 96 | return _ 97 | 98 | getHole : Tac Term 99 | getHole = goalTac λ goal → done (goal .theHole) , goal 100 | 101 | setHole : Term → Tac ⊤ 102 | setHole hole = goalTac λ goal → done _ , mkGoal hole (goal .goalCtx) 103 | 104 | getCtx : Tac Telescope 105 | getCtx = goalTac λ goal → done (goal .goalCtx) , goal 106 | 107 | addCtx : Arg Type → Tac ⊤ 108 | addCtx b = goalTac λ goal → done _ , mkGoal (goal .theHole) (("x" , b) ∷ goal .goalCtx) 109 | 110 | fork : Tac Bool 111 | fork = forkTac (done false) (done true) 112 | 113 | liftTC' : TC (Tac A) → TC A → Tac A 114 | liftTC' err m = goalTac λ goal → (_, goal) $ 115 | step $ TC.catchTC 116 | (done <$> foldl (flip (uncurry TC.extendContext)) m (goal .goalCtx)) 117 | err 118 | 119 | -- Run TC action, backtracking on failure 120 | liftTC : TC A → Tac A 121 | liftTC = liftTC' $ return failTac 122 | 123 | -- Run TC action, raising IMPOSSIBLE on failure 124 | liftTC! : TC A → Tac A 125 | liftTC! {A = A} m = liftTC' fail m 126 | where 127 | fail : TC (Tac A) 128 | fail = TC.bindTC 129 | (TC.quoteTC m) 130 | (λ `m → TC.typeError $ strErr "Primitive TC action" ∷ termErr `m ∷ strErr "failed!" ∷ []) 131 | 132 | {-# TERMINATING #-} 133 | fmapTac : (A → B) → Tac {ℓ} A → Tac {ℓ′} B 134 | fmapTac g (done x ) = done $ g x 135 | fmapTac {ℓ = ℓ} {ℓ′ = ℓ′} g (step mtac) = step $ lowerF {ℓ = ℓ} (mapLift′ (fmapTac g) <$> liftF {ℓ = ℓ′} mtac) 136 | fmapTac g (goalTac f) = goalTac λ goal → first (fmapTac g) $ f goal 137 | fmapTac g failTac = failTac 138 | fmapTac g (chooseTac tac₁ tac₂) = chooseTac (fmapTac g tac₁) (fmapTac g tac₂) 139 | fmapTac g skipTac = skipTac 140 | fmapTac g (forkTac tac₁ tac₂) = forkTac (fmapTac g tac₁) (fmapTac g tac₂) 141 | 142 | {-# TERMINATING #-} 143 | bindTac : Tac {ℓ} A → (A → Tac {ℓ} B) → Tac B 144 | bindTac (done x) g = g x 145 | bindTac (step mtac) g = step $ flip bindTac g <$> mtac 146 | bindTac (goalTac f) g = goalTac λ goal → first (flip bindTac g) $ f goal 147 | bindTac failTac g = failTac 148 | bindTac (chooseTac tac₁ tac₂) g = chooseTac (bindTac tac₁ g) (bindTac tac₂ g) 149 | bindTac skipTac g = skipTac 150 | bindTac (forkTac tac₁ tac₂) g = forkTac (bindTac tac₁ g) (bindTac tac₂ g) 151 | 152 | {-# TERMINATING #-} 153 | liftFTac : Tac A → Tac (Lift ℓ A) 154 | liftFTac = fmapTac lift 155 | 156 | lowerFTac : Tac (Lift ℓ A) → Tac A 157 | lowerFTac = fmapTac lower 158 | 159 | instance 160 | monadTac : Monad (Tac {ℓ}) 161 | monadTac = mkMonad _ done bindTac 162 | 163 | functorTac : Functor (Tac {ℓ}) 164 | functorTac = Monad.rawFunctor it 165 | 166 | applicativeTac : Applicative (Tac {ℓ}) 167 | applicativeTac = Monad.rawApplicative it 168 | 169 | applicativeZeroTac : ApplicativeZero (Tac {ℓ}) 170 | applicativeZeroTac .ApplicativeZero.rawApplicative = it 171 | applicativeZeroTac .ApplicativeZero.rawEmpty .Empty.empty = failTac 172 | 173 | alternativeTac : Alternative (Tac {ℓ}) 174 | alternativeTac .Alternative.rawApplicativeZero = it 175 | alternativeTac .Alternative.rawChoice .Choice._<|>_ = chooseTac 176 | 177 | functorLiftTac : FunctorLift Tac ℓ A 178 | functorLiftTac .liftF = liftFTac 179 | functorLiftTac .lowerF = lowerFTac 180 | 181 | tacCore : TacCore 182 | tacCore = λ where 183 | .TacCore.Tac → Tac 184 | .TacCore.runTac → toMacro 185 | .TacCore.getHole → getHole 186 | .TacCore.setHole → setHole 187 | .TacCore.getCtx → getCtx 188 | .TacCore.addCtx → addCtx 189 | .TacCore.liftTC → liftTC 190 | .TacCore.liftTC! → liftTC! 191 | .TacCore.fork → fork 192 | .TacCore.skip → skipTac 193 | 194 | open TacCore tacCore public 195 | -------------------------------------------------------------------------------- /src/Ataca/Demo.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Ataca.Utils 3 | open import Ataca.Core 4 | open import Ataca.Tactics 5 | 6 | open import Agda.Builtin.Nat 7 | open import Data.List.Relation.Unary.Any 8 | 9 | module Ataca.Demo where 10 | 11 | test₁ : ℕ 12 | test₁ = {! exact 42 !} 13 | 14 | test₂ : ℕ → Bool → ℕ 15 | test₂ x y = {! assumption !} 16 | 17 | test₃ : ℕ → Bool → Bool 18 | test₃ x y = {! assumption !} 19 | 20 | test₄ : ℕ → Bool → ℕ 21 | test₄ = {! intros !} 22 | 23 | test₅ : Bool 24 | test₅ = {! introConstructor !} 25 | 26 | test₆ : ℕ 27 | test₆ = {! introConstructor !} 28 | 29 | test₇ : _≡_ {A = Bool} true true 30 | test₇ = {! introConstructor !} 31 | 32 | test₈ : Vec ℕ 0 33 | test₈ = {! introConstructor!} 34 | 35 | test₉ : Vec Bool 3 36 | test₉ = {! introConstructors !} 37 | 38 | test₁₀ : {A : Set} → A → Vec A 5 39 | test₁₀ = {! mini-auto !} 40 | 41 | data DecrVec (n : ℕ) : ℕ → Set where 42 | [] : DecrVec n zero 43 | cons : ∀ {k} → (m : ℕ) → m ℕ.< n → DecrVec m k → DecrVec n (suc k) 44 | 45 | test₁₁ : DecrVec 4 3 46 | test₁₁ = {! mini-auto !} 47 | 48 | test₁₂ : Any {A = ℕ} (_≡ 1) (zero ∷ (suc zero) ∷ []) 49 | test₁₂ = {! mini-auto !} 50 | 51 | postulate 52 | X Y : Set 53 | fun : X → Y 54 | 55 | test₁₃ : X → Y 56 | test₁₃ = {! mini-auto-with hints !} 57 | where 58 | hints : Hints 59 | hints = def (quote fun) [] ∷ [] 60 | 61 | test₁₄ : {A : Set} → ⊥ → A 62 | test₁₄ = {! mini-auto!} 63 | 64 | -- Doesn't work yet 65 | -- test₁₅ : (x : ℕ) → (x ≡ 0) ⊎ (Σ ℕ λ y → x ≡ suc y) 66 | -- test₁₅ x = {! destruct x !} 67 | 68 | postulate 69 | P=NP : Set 70 | 71 | proof : P=NP 72 | proof = run do 73 | try mini-auto' 74 | admit' 75 | -------------------------------------------------------------------------------- /src/Ataca/Tactics.agda: -------------------------------------------------------------------------------- 1 | 2 | module Ataca.Tactics where 3 | 4 | open import Ataca.Tactics.BasicTactics public 5 | open import Ataca.Tactics.Exact public 6 | open import Ataca.Tactics.Admit public 7 | open import Ataca.Tactics.Assumption public 8 | open import Ataca.Tactics.Intro public 9 | open import Ataca.Tactics.Constructor public 10 | open import Ataca.Tactics.Refine public 11 | open import Ataca.Tactics.Destruct public 12 | open import Ataca.Tactics.MiniAuto public 13 | -------------------------------------------------------------------------------- /src/Ataca/Tactics/Admit.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --postfix-projections #-} 2 | 3 | module Ataca.Tactics.Admit where 4 | 5 | open import Ataca.Utils 6 | open import Ataca.Core 7 | open import Ataca.Tactics.BasicTactics 8 | open import Ataca.Tactics.Exact 9 | 10 | admit' : Tac A 11 | admit' = do 12 | lift (hole , holeType) ← liftF getHoleWithType 13 | lift x ← liftF $ freshName "ADMIT" 14 | liftF $ declarePostulate (vArg x) holeType 15 | exact' (def x []) 16 | 17 | macro 18 | admit : Tactic 19 | admit = runTac admit' 20 | -------------------------------------------------------------------------------- /src/Ataca/Tactics/Assumption.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --postfix-projections #-} 2 | 3 | module Ataca.Tactics.Assumption where 4 | 5 | open import Ataca.Utils 6 | open import Ataca.Core 7 | open import Ataca.Tactics.BasicTactics 8 | open import Ataca.Tactics.Exact 9 | 10 | tryVar : ℕ → Tac A 11 | tryVar i = do 12 | liftF $ debug "assumption" 10 $ strErr "Trying variable" ∷ strErr (ℕ.show i) ∷ [] 13 | exact' $ var i [] 14 | 15 | assumption' : Tac A 16 | assumption' = unlessSolved $ do 17 | lift ctx ← liftF $ map snd <$> getContext 18 | liftF $ debug "assumption" 20 $ strErr "Current context:" ∷ map (termErr ∘ unArg) ctx 19 | let vars = List.upTo (length ctx) 20 | choice1 $ map tryVar vars 21 | 22 | macro 23 | assumption : Tactic 24 | assumption = runTac assumption' 25 | -------------------------------------------------------------------------------- /src/Ataca/Tactics/BasicTactics.agda: -------------------------------------------------------------------------------- 1 | module Ataca.Tactics.BasicTactics where 2 | 3 | open import Ataca.Utils 4 | open import Ataca.Core 5 | 6 | module _ where 7 | unify : Term → Term → Tac ⊤ 8 | unify u v = liftTC $ TC.unify u v 9 | 10 | inferType : Term → Tac Type 11 | inferType u = liftTC! $ TC.inferType u 12 | 13 | checkType : Term → Type → Tac Term 14 | checkType u a = liftTC! $ TC.checkType u a 15 | 16 | newMeta : Type → Tac Term 17 | newMeta a = liftTC! $ TC.newMeta a 18 | 19 | newMeta! : Tac Term 20 | newMeta! = liftTC! TC.newMeta! 21 | 22 | newMetaCtx : Telescope → Type → Tac Term 23 | newMetaCtx tel a = liftTC! $ extendCtxTel tel $ TC.newMeta a 24 | 25 | newMetaCtx! : Telescope → Tac Term 26 | newMetaCtx! tel = liftTC! $ extendCtxTel tel TC.newMeta! 27 | 28 | normalise : Term → Tac Term 29 | normalise u = liftTC! $ TC.normalise u 30 | 31 | reduce : Term → Tac Term 32 | reduce u = liftTC! $ TC.reduce u 33 | 34 | quoteTac : A → Tac Term 35 | quoteTac x = liftTC! $ TC.quoteTC x 36 | 37 | unquoteTac : Term → Tac A 38 | unquoteTac u = liftTC! $ TC.unquoteTC u 39 | 40 | getContext : Tac Telescope 41 | getContext = liftTC! TC.getContext 42 | 43 | freshName : String → Tac Name 44 | freshName n = liftTC! $ TC.freshName n 45 | 46 | declareDef : Arg Name → Type → Tac ⊤ 47 | declareDef n a = liftTC! $ TC.declareDef n a 48 | 49 | declarePostulate : Arg Name → Type → Tac ⊤ 50 | declarePostulate n a = liftTC! $ TC.declarePostulate n a 51 | 52 | defineFun : Name → List Clause → Tac ⊤ 53 | defineFun n cs = liftTC! $ TC.defineFun n cs 54 | 55 | getType : Name → Tac Type 56 | getType n = liftTC! $ TC.getType n 57 | 58 | getDefinition : Name → Tac Definition 59 | getDefinition n = liftTC! $ TC.getDefinition n 60 | 61 | error : List ErrorPart → Tac A 62 | error msg = liftTC! $ TC.bindTC 63 | (TC.debugPrint "tac" 1 msg) 64 | (λ _ → TC.typeError []) 65 | 66 | debug : String → ℕ → List ErrorPart → Tac ⊤ 67 | debug s n msg = liftTC! $ TC.debugPrint ("tac." String.++ s) n msg 68 | 69 | backtrack : Tac A 70 | backtrack = empty 71 | 72 | pass : A → Tac A 73 | pass x = return x 74 | 75 | getHoleWithType : Tac (Term × Type) 76 | getHoleWithType = do 77 | hole ← getHole 78 | holeType ← inferType hole 79 | return (hole , holeType) 80 | 81 | noMoreGoals : Tac A 82 | noMoreGoals = do 83 | lift (hole , holeType) ← liftF getHoleWithType 84 | error $ strErr "Unsolved subgoal: " ∷ termErr hole ∷ strErr ":" ∷ termErr holeType ∷ [] 85 | 86 | now : Tac A → Tac B 87 | now {a} {A} {b} {B} tac = lowerF {ℓ = a} (liftF {ℓ = b} tac >> noMoreGoals) 88 | 89 | try : Tac A → Tac (Maybe A) 90 | try tac = (just <$> tac) <|> return nothing 91 | 92 | repeat : ℕ → Tac ⊤ → Tac ⊤ 93 | repeat zero tac = return _ 94 | repeat (suc k) tac = tac >> repeat k tac 95 | 96 | fork2 : Tac A → Tac B → Tac (A ⊎ B) 97 | fork2 {a} {A} {b} {B} tac₁ tac₂ = lowerF {ℓ = a ⊔ b} $ 98 | liftF {ℓ = a ⊔ b} fork >>= λ where 99 | (lift false) → mapLift left <$> liftF tac₁ 100 | (lift true) → mapLift right <$> liftF tac₂ 101 | 102 | forkN : {A : Fin n → Set ℓ} 103 | → ((i : Fin n) → Tac (A i)) → Tac (Σ (Fin n) A) 104 | forkN {n = zero } tac = skip 105 | forkN {n = suc n} tac = do 106 | fork2 (tac zero) (forkN (tac ∘ suc)) >>= λ where 107 | (left x) → return $ zero , x 108 | (right (i , y)) → return $ suc i , y 109 | 110 | forEach : List A → (A → Tac B) → Tac B 111 | forEach xs f = snd <$> (forkN $ f ∘ Vec.lookup (Vec.fromList xs)) 112 | 113 | qed : Tac A 114 | qed = do 115 | lift (hole , holeType) ← liftF getHoleWithType 116 | liftF (reduce hole) >>= λ where 117 | (lift hole@(meta _ _)) → do 118 | --debug "qed" 25 $ strErr "Unsolved subgoal: " ∷ termErr hole ∷ strErr ":" ∷ termErr holeType ∷ [] 119 | backtrack 120 | _ → skip 121 | 122 | unlessSolved : Tac A → Tac A 123 | unlessSolved tac = qed <|> tac 124 | -------------------------------------------------------------------------------- /src/Ataca/Tactics/Constructor.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --postfix-projections #-} 2 | 3 | module Ataca.Tactics.Constructor where 4 | 5 | open import Ataca.Utils 6 | open import Ataca.Core 7 | open import Ataca.Tactics.BasicTactics 8 | open import Ataca.Tactics.Refine 9 | 10 | isDataOrRecord : Type → Tac (List (Arg Term) × List Name × ℕ) 11 | isDataOrRecord t = do 12 | def d us ← reduce t 13 | where _ → do 14 | debug "introConstructor" 9 $ strErr "Not a data/record type: " ∷ termErr t ∷ [] 15 | backtrack 16 | debug "constr" 30 $ strErr "Found a def" ∷ termErr (def d []) ∷ strErr "applied to arguments" ∷ map (termErr ∘ unArg) us 17 | getDefinition d >>= λ where 18 | (data-type #pars cons) → do 19 | debug "constr" 20 $ strErr "It's a datatype applied to" ∷ strErr (ℕ.show #pars) ∷ strErr "parameters" ∷ [] 20 | return $ us , cons ,′ #pars 21 | (record′ c fields) → do 22 | debug "constr" 20 $ strErr "It's a record type" ∷ [] 23 | return $ us , [ c ] , length us 24 | _ → do 25 | debug "introConstructor" 9 $ strErr "Not a data/record type: " ∷ termErr t ∷ [] 26 | backtrack 27 | 28 | getConstructor : Type → Tac ((List (Arg Term) → Term) × List ArgInfo) 29 | getConstructor t = do 30 | us , cons , #pars ← isDataOrRecord t 31 | let pars = take #pars us 32 | ipars = map makeImplicit pars 33 | choice1 $ for cons $ λ c → do 34 | t ← getType c 35 | debug "constr" 10 $ strErr "Constructor" ∷ termErr (con c []) ∷ strErr "has type" ∷ termErr t ∷ [] 36 | ais ← liftTC $ piArgInfos t 37 | debug "constr" 10 $ strErr "Now trying constructor" ∷ termErr (con c []) ∷ [] 38 | return $ (λ args → con c (ipars ++ args)) , drop #pars ais 39 | 40 | introConstructor' : Tac ⊤ 41 | introConstructor' = do 42 | _ , holeType ← getHoleWithType 43 | debug "constr" 20 $ strErr "Trying introConstructor on " ∷ termErr holeType ∷ [] 44 | c , is ← getConstructor holeType 45 | refineN' is c 46 | 47 | macro 48 | introConstructor : Tactic 49 | introConstructor = runTac introConstructor' 50 | 51 | introConstructors : Tactic 52 | introConstructors = runTac $ repeat 10 (introConstructor' <|> return _) 53 | -------------------------------------------------------------------------------- /src/Ataca/Tactics/Destruct.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --postfix-projections #-} 2 | 3 | module Ataca.Tactics.Destruct where 4 | 5 | open import Ataca.Utils 6 | open import Ataca.Core 7 | open import Ataca.Tactics.BasicTactics 8 | open import Ataca.Tactics.Exact 9 | open import Ataca.Tactics.Constructor 10 | 11 | data Is {A : Set ℓ} : A → Set ℓ where 12 | ⌊_⌋ : (x : A) → Is x 13 | 14 | split : (x : A) → (Is x → B) → B 15 | split x f = f ⌊ x ⌋ 16 | 17 | {-# NOINLINE split #-} 18 | 19 | destruct' : Term → Tac ⊤ 20 | destruct' u = do 21 | t ← inferType u 22 | us , cons , #pars ← isDataOrRecord t 23 | cls ← flip traverse cons λ c → do 24 | ct ← getType c 25 | tel , ctarget ← liftTC $ telePi ct 26 | let ais = teleArgInfos tel 27 | xs = List.downFrom (length tel) 28 | debug "destruct" 40 $ strErr "Constructor" ∷ termErr (con c []) ∷ strErr "with type" ∷ termErr ct ∷ [] 29 | let pat : Pattern 30 | pat = con (quote ⌊_⌋) (vArg (con c $ zipWith (λ i x → arg i (var x)) ais xs) ∷ []) 31 | return $ clause tel (vArg pat ∷ []) unknown 32 | 33 | let 34 | solution : Term 35 | solution = def (quote split) ( 36 | vArg u ∷ 37 | vArg (pat-lam cls []) ∷ []) 38 | 39 | debug "destruct" 10 (strErr "Destruct solution: " ∷ termErr solution ∷ []) 40 | 41 | hole ← getHole 42 | unify hole solution 43 | pat-lam cls' _ ← reduce hole 44 | where _ → liftTC $ TC.typeError (strErr "IMPOSSIBLE" ∷ []) 45 | forEach cls' λ where 46 | (clause _ ps ?rhs) → do 47 | rhsType ← inferType ?rhs 48 | debug "destruct" 20 (strErr "Destruct subgoal: " ∷ termErr ?rhs ∷ strErr ":" ∷ termErr rhsType ∷ []) 49 | -- TODO: Set the right context 50 | setHole ?rhs 51 | (absurd-clause _ _) → liftTC $ TC.typeError (strErr "IMPOSSIBLE" ∷ []) 52 | 53 | 54 | 55 | macro 56 | destruct : Term → Term → TC ⊤ 57 | destruct u = runTac $ destruct' u 58 | -------------------------------------------------------------------------------- /src/Ataca/Tactics/Exact.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --postfix-projections #-} 2 | 3 | module Ataca.Tactics.Exact where 4 | 5 | open import Ataca.Utils 6 | open import Ataca.Core 7 | open import Ataca.Tactics.BasicTactics 8 | 9 | exact' : Term → Tac A 10 | exact' solution = unlessSolved $ do 11 | lift hole ← liftF getHole 12 | liftF $ debug "exact" 10 $ strErr "Solving goal" ∷ termErr hole ∷ strErr "with solution" ∷ termErr solution ∷ [] 13 | liftF $ unify hole solution 14 | qed 15 | 16 | macro 17 | exact : A → Tactic 18 | exact u = runTac $ (quoteTac u) >>= exact' 19 | -------------------------------------------------------------------------------- /src/Ataca/Tactics/Intro.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --postfix-projections #-} 2 | 3 | module Ataca.Tactics.Intro where 4 | 5 | open import Ataca.Utils 6 | open import Ataca.Core 7 | open import Ataca.Tactics.BasicTactics 8 | 9 | intro' : Tac ⊤ 10 | intro' = unlessSolved $ do 11 | hole , holeType ← getHoleWithType 12 | debug "intro" 10 $ strErr "Trying intro on" ∷ termErr holeType ∷ [] 13 | pi a@(arg i _) b@(abs x _) ← reduce holeType 14 | where t → do 15 | debug "intro" 8 $ strErr "Not a function type: " ∷ termErr t ∷ [] 16 | backtrack 17 | body ← newMetaCtx ((x , a) ∷ []) $ unAbs b 18 | let v = visibility i 19 | unify hole (lam v (abs x body)) 20 | addCtx a 21 | setHole body 22 | 23 | macro 24 | intro : Tactic 25 | intro = runTac intro' 26 | 27 | intros : Tactic 28 | intros = runTac $ repeat 10 (intro' <|> return _) 29 | 30 | introAbsurd' : Tac ⊤ 31 | introAbsurd' = unlessSolved $ do 32 | hole , holeType ← getHoleWithType 33 | debug "intro" 10 $ strErr "Trying introAbsurd on" ∷ termErr holeType ∷ [] 34 | pi a@(arg i _) b ← reduce holeType 35 | where t → do 36 | debug "intro" 8 $ strErr "Not a function type: " ∷ termErr t ∷ [] 37 | backtrack 38 | unify hole (pat-lam [ absurd-clause [] [ arg i (absurd 0) ] ] []) 39 | qed 40 | 41 | macro 42 | introAbsurd = runTac introAbsurd' 43 | -------------------------------------------------------------------------------- /src/Ataca/Tactics/MiniAuto.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --postfix-projections #-} 2 | 3 | module Ataca.Tactics.MiniAuto where 4 | 5 | open import Ataca.Utils 6 | open import Ataca.Core 7 | open import Ataca.Tactics.BasicTactics 8 | open import Ataca.Tactics.Assumption 9 | open import Ataca.Tactics.Intro 10 | open import Ataca.Tactics.Constructor 11 | open import Ataca.Tactics.Refine 12 | 13 | Hints = List Term 14 | 15 | mini-auto-with' : Hints → Tac ⊤ 16 | mini-auto-with' hints = repeat 10 $ choice1 $ 17 | assumption' ∷ intro' ∷ introAbsurd' ∷ introConstructor' ∷ map refine' hints 18 | 19 | mini-auto' : Tac ⊤ 20 | mini-auto' = mini-auto-with' [] 21 | 22 | macro 23 | mini-auto-with : Hints → Tactic 24 | mini-auto-with hints = runTac $ mini-auto-with' hints 25 | 26 | mini-auto : Tactic 27 | mini-auto = runTac mini-auto' 28 | -------------------------------------------------------------------------------- /src/Ataca/Tactics/Refine.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --postfix-projections #-} 2 | 3 | module Ataca.Tactics.Refine where 4 | 5 | open import Ataca.Utils 6 | open import Ataca.Core 7 | open import Ataca.Tactics.BasicTactics 8 | 9 | refineN' : List ArgInfo → (List (Arg Term) → Term) → Tac ⊤ 10 | refineN' is hd = do 11 | debug "refine" 10 $ strErr "Trying to refine goal with" ∷ termErr (hd []) ∷ strErr "applied to" ∷ strErr (ℕ.show (length is)) ∷ strErr "arguments" ∷ [] 12 | loop is hd [] 13 | 14 | where 15 | loop : List ArgInfo → (List (Arg Term) → Term) → List Term → Tac ⊤ 16 | loop [] hd subgoals = do 17 | hole ← getHole 18 | debug "refine" 15 $ strErr "Solving goal" ∷ termErr hole ∷ strErr "with solution" ∷ termErr (hd []) ∷ [] 19 | unify hole (hd []) 20 | debug "refine" 15 $ strErr "Instantiation successful, new subgoals" ∷ map termErr subgoals 21 | forEach subgoals setHole 22 | loop (i ∷ is) hd subgoals = do 23 | x ← newMeta! 24 | loop is (hd ∘ (arg i x ∷_)) (x ∷ subgoals) 25 | 26 | refine' : Term → Tac ⊤ 27 | refine' u = do 28 | hd , t ← case u of λ where 29 | (var x us) → ⦇ return (λ vs → var x (us ++ vs)) , inferType (var x us) ⦈ 30 | (con c []) → ⦇ return (con c) , getType c ⦈ 31 | (con c us) → ⦇ return (λ vs → con c (us ++ vs)) , inferType (con c us) ⦈ 32 | (def f []) → ⦇ return (def f) , getType f ⦈ 33 | (def f us) → ⦇ return (λ vs → def f (us ++ vs)) , inferType (def f us) ⦈ 34 | (pi a b) → ⦇ return (const $ pi a b) , (inferType (pi a b)) ⦈ 35 | (sort s) → ⦇ return (const $ sort s) , (inferType (sort s)) ⦈ 36 | (lit l) → ⦇ return (const $ lit l) , (inferType (lit l)) ⦈ 37 | (meta x us) → ⦇ return (λ vs → meta x (us ++ vs)) , inferType (meta x us) ⦈ 38 | _ → error $ strErr "Not supported by refine: " ∷ termErr u ∷ [] 39 | is ← liftTC $ piArgInfos t 40 | choice1 $ for (List.upTo (length is)) λ #args → 41 | refineN' (take #args is) hd 42 | 43 | macro 44 | refine : Term → Tactic 45 | refine u = runTac $ refine' u 46 | -------------------------------------------------------------------------------- /src/Ataca/Tests.agda: -------------------------------------------------------------------------------- 1 | 2 | open import Ataca.Utils 3 | open import Ataca.Core 4 | open import Ataca.Tactics 5 | 6 | module Ataca.Tests where 7 | 8 | test₀ : ℕ 9 | test₀ = run doIt 10 | where 11 | doIt : Tac ⊤ 12 | doIt = choice1 $ 13 | (do 14 | x ← newMeta! 15 | hole ← getHole 16 | unify hole (con (quote ℕ.suc) (vArg x ∷ [])) 17 | backtrack) 18 | ∷ (do 19 | hole ← getHole 20 | unify hole (con (quote ℕ.zero) [])) 21 | ∷ [] 22 | 23 | test₁ : ℕ 24 | test₁ = exact 42 25 | 26 | test₂ : ℕ → Bool → ℕ 27 | test₂ x y = x 28 | 29 | test₃ : ℕ → Bool → Bool 30 | test₃ x y = mini-auto 31 | 32 | test₄ : ℕ → Bool → ℕ 33 | test₄ = mini-auto 34 | 35 | test₅ : Bool 36 | test₅ = mini-auto 37 | 38 | test₆ : ℕ 39 | test₆ = mini-auto 40 | 41 | test₇ : true ≡ true 42 | test₇ = mini-auto 43 | 44 | test₈ : Vec ℕ 0 45 | test₈ = mini-auto 46 | 47 | test₉ : Vec Bool 3 48 | test₉ = mini-auto 49 | 50 | test₁₀ : {A : Set} → A → Vec A 5 51 | test₁₀ = mini-auto 52 | 53 | data DecrVec (n : ℕ) : ℕ → Set where 54 | [] : DecrVec n zero 55 | cons : ∀ {k} → (m : ℕ) → m ℕ.< n → DecrVec m k → DecrVec n (suc k) 56 | 57 | test₁₁ : DecrVec 4 3 58 | test₁₁ = mini-auto 59 | 60 | data ℕList : Set where 61 | [] : ℕList 62 | _∷_ : (x : ℕ) (xs : ℕList) → ℕList 63 | 64 | data Is1 : ℕ → Set where 65 | instance is1 : Is1 1 66 | 67 | data Any1 : ℕList → Set where 68 | instance 69 | zero : ∀ {x xs} {{p : Is1 x}} → Any1 (x ∷ xs) 70 | suc : ∀ {x xs} {{i : Any1 xs}} → Any1 (x ∷ xs) 71 | 72 | test₁₂ : Any1 (zero ∷ (suc zero) ∷ []) 73 | test₁₂ = mini-auto 74 | 75 | postulate 76 | Atype Btype : Set 77 | fun : Atype → Btype 78 | 79 | test₁₃ : Atype → Btype 80 | test₁₃ = mini-auto-with hints 81 | where hints = def (quote fun) [] ∷ [] 82 | 83 | postulate 84 | P=NP : Set 85 | 86 | proof : P=NP 87 | proof = run do 88 | try mini-auto' 89 | admit' 90 | 91 | test₁₄ : {A : Set} → ⊥ → A 92 | test₁₄ = mini-auto 93 | -------------------------------------------------------------------------------- /src/Ataca/Utils.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-qualified-instances #-} 2 | 3 | module Ataca.Utils where 4 | 5 | open import Data.Bool.Base public using (Bool; true; false) hiding (module Bool) 6 | module Bool = Data.Bool.Base 7 | open import Data.Empty public using (⊥; ⊥-elim) 8 | open import Data.Fin.Base public using (Fin; zero; suc) hiding (module Fin) 9 | module Fin = Data.Fin.Base 10 | open import Data.List.Base public using (List; []; _∷_; [_]; map; foldl; foldr; length; _++_; take; drop; zipWith) hiding (module List) 11 | module List = Data.List.Base 12 | open import Data.Maybe.Base public using (Maybe; nothing; just) 13 | open import Data.Nat.Base public using (ℕ; zero; suc) hiding (module ℕ) 14 | module ℕ where 15 | open import Data.Nat.Base public 16 | open import Data.Nat.Show public 17 | open import Data.Product public using (Σ; _×_; _,_; _,′_; curry; uncurry) renaming (proj₁ to fst; proj₂ to snd; map₁ to first; map₂ to second) 18 | open import Data.String.Base public using (String) 19 | module String = Data.String.Base 20 | open import Data.Sum.Base public using (_⊎_) renaming (inj₁ to left; inj₂ to right) 21 | open import Data.Unit public using (⊤; tt) 22 | open import Data.Vec.Base public using (Vec; []; _∷_) hiding (module Vec) 23 | module Vec = Data.Vec.Base 24 | 25 | open import Function.Base public using (const; id; flip; _∘_; _$_; it; case_of_) 26 | 27 | open import Level public using (Level; Setω; 0ℓ; _⊔_; Lift; lift; lower) renaming (suc to sucℓ) 28 | 29 | open import Relation.Binary.PropositionalEquality using (_≡_; refl) public 30 | 31 | open import Reflection.AST.Term public 32 | open import Reflection.AST.Name public using (Name) 33 | open import Reflection.AST.Definition public hiding (_≟_) 34 | open import Reflection.AST.Abstraction public using (Abs; abs; unAbs) 35 | open import Reflection.AST.Argument public using (Arg; arg; vArg; hArg; unArg) 36 | open import Reflection.AST.Argument.Modality using (Modality) public 37 | open import Reflection.AST.Argument.Visibility using (Visibility; visible; instance′; hidden) public 38 | open import Reflection.AST.Argument.Relevance using (Relevance; relevant; irrelevant) public 39 | open import Reflection.AST.Argument.Information public using (ArgInfo; arg-info; visibility; modality) 40 | 41 | open import Data.List.Instances public -- hiding (listMonadT) 42 | open import Data.Maybe.Instances public -- hiding (maybeMonadT) 43 | open import Reflection.TCM.Instances public 44 | 45 | open import Reflection.TCM public using (ErrorPart; strErr; termErr) 46 | 47 | open import Effect.Empty public using () renaming (RawEmpty to Empty) 48 | open import Effect.Choice public using () renaming (RawChoice to Choice) 49 | open import Effect.Functor public using () renaming (RawFunctor to Functor) 50 | open import Effect.Applicative public using () 51 | renaming ( RawApplicative to Applicative 52 | ; RawApplicativeZero to ApplicativeZero 53 | ; RawAlternative to Alternative 54 | ) 55 | open import Effect.Monad public using () renaming ( RawMonad to Monad ; mkRawMonad to mkMonad) 56 | open Functor {{...}} public using (_<$>_; _<$_) 57 | open Applicative {{...}} public using (pure) renaming (_⊛_ to _<*>_) 58 | open ApplicativeZero {{...}} public using () renaming (∅ to empty) 59 | open Alternative {{...}} public using () renaming (_∣_ to _<|>_) 60 | open Monad {{...}} public using (return; _>>=_; _>>_) 61 | 62 | -- Generalized names 63 | 64 | variable 65 | k l m n : ℕ 66 | ℓ ℓ′ ℓ″ : Level 67 | A B C : Set ℓ 68 | F M : Set ℓ → Set ℓ′ 69 | 70 | -- Some utility functions 71 | 72 | for : List A → (A → B) → List B 73 | for = flip map 74 | 75 | fmap = _<$>_ 76 | 77 | void : {{Functor F}} → F A → F ⊤ 78 | void m = const _ <$> m 79 | 80 | choice1 : {{Alternative F}} → List (F A) → F A 81 | choice1 [] = empty 82 | where instance applicativeZeroF = Alternative.rawApplicativeZero it 83 | choice1 (f ∷ []) = f 84 | choice1 (f ∷ fs) = f <|> choice1 fs 85 | 86 | monadAp : {{Monad M}} → M (A → B) → M A → M B 87 | monadAp {{monadM}} mf mx = do 88 | f ← mf 89 | x ← mx 90 | return (f x) 91 | 92 | traverse : {{Monad M}} → (A → M B) → List A → M (List B) 93 | traverse f [] = return [] 94 | traverse f (mx ∷ mxs) = do 95 | x ← f mx 96 | xs ← traverse f mxs 97 | return (x ∷ xs) 98 | 99 | mapLift′ : (f : A → B) → Lift ℓ A → Lift ℓ′ B 100 | mapLift′ f (lift x) = lift (f x) 101 | 102 | mapLift : (f : A → B) → Lift ℓ A → Lift ℓ B 103 | mapLift = mapLift′ 104 | 105 | record FunctorLift {a} (F : ∀ {ℓ′} → Set ℓ′ → Set ℓ′) ℓ (A : Set a) : Set (sucℓ ℓ ⊔ a) where 106 | field 107 | liftF : F A → F (Lift ℓ A) 108 | lowerF : F (Lift ℓ A) → F A 109 | 110 | open FunctorLift {{...}} public 111 | 112 | -- Reflection stuff 113 | 114 | module TC where 115 | open import Reflection.TCM public 116 | newMeta! = newMeta unknown 117 | 118 | TC = TC.TC 119 | 120 | Tactic = Term → TC ⊤ 121 | 122 | makeImplicit : Arg A → Arg A 123 | makeImplicit (arg (arg-info v r) x) = arg (arg-info hidden r) x 124 | 125 | extendCtxTel : Telescope → TC A → TC A 126 | extendCtxTel [] = id 127 | extendCtxTel ((x , a) ∷ tel) = TC.extendContext x a ∘ extendCtxTel tel 128 | 129 | goalErr : Term → TC (List TC.ErrorPart) 130 | goalErr goal = do 131 | goalType ← TC.inferType goal 132 | return $ TC.termErr goal ∷ TC.strErr ":" ∷ TC.termErr goalType ∷ [] 133 | 134 | piView : Type → TC (Maybe (Arg Type × Abs Type)) 135 | piView = λ where 136 | -- HACK: first try without reducing the type to avoid creating 137 | -- spurious constraints, then try again if that doesn't work. 138 | (pi a b) → return $ just (a , b) 139 | t → TC.reduce t >>= λ where 140 | (pi a b) → return $ just (a , b) 141 | _ → return nothing 142 | 143 | {-# TERMINATING #-} 144 | telePi : Type → TC (Telescope × Type) 145 | telePi t = piView t >>= λ where 146 | (just (a , (abs x b))) → first ((x , a) ∷_) <$> TC.extendContext x a (telePi b) 147 | nothing → return ([] , t) 148 | 149 | getArgInfo : Arg A → ArgInfo 150 | getArgInfo (arg i _) = i 151 | 152 | teleArgInfos : Telescope → List ArgInfo 153 | teleArgInfos = map (getArgInfo ∘ snd) 154 | 155 | piArgInfos : Type → TC (List ArgInfo) 156 | piArgInfos t = teleArgInfos ∘ fst <$> telePi t 157 | 158 | instance 159 | functorLiftTC : FunctorLift TC ℓ A 160 | functorLiftTC .liftF = λ mx → TC.bindTC mx (λ x → TC.pure (lift x)) 161 | functorLiftTC .lowerF = λ mx → TC.bindTC mx (λ x → TC.pure (lower x)) 162 | --------------------------------------------------------------------------------