{-# OPTIONS --safe --without-K #-}
--------------------------------------------------------------------------------
-- Improved TC
--------------------------------------------------------------------------------

module Reflection.TCI where

open import Meta.Prelude

open import Data.List using (map)

import Agda.Builtin.Reflection as R'
import Reflection as R
open import Reflection.Syntax

open import Class.Monad hiding (Monad-TC)
open import Class.MonadError using (MonadError)
open import Class.MonadReader
open import Class.MonadTC

open Monad

TC : Set ℓ → Set ℓ
TC = ReaderT TCEnv R.TC

Monad-TC : Monad TC
Monad-TC = Monad-ReaderT

MonadReader-TC : MonadReader TCEnv TC ⦃ Monad-TC ⦄
MonadReader-TC = MonadReader-ReaderT

instance _ = Class.MonadError.MonadError-TC

MonadError-TC : MonadError (List ErrorPart) TC
MonadError-TC = MonadError-ReaderT

applyReductionOptions : TC A → TC A
applyReductionOptions x r@record { reduction = onlyReduce red } = R'.withReduceDefs (true ,  red) (x r)
applyReductionOptions x r@record { reduction = dontReduce red } = R'.withReduceDefs (false , red) (x r)

applyNormalisation : TC A → TC A
applyNormalisation x r@record { normalisation = n } = R.withNormalisation n (applyReductionOptions x r)

applyReconstruction : TC A → TC A
applyReconstruction x r@record { reconstruction = false } = x r
applyReconstruction x r@record { reconstruction = true  } = R'.withReconstructed true (x r)

applyNoConstraints : TC A → TC A
applyNoConstraints x r@record { noConstraints = false } = x r
applyNoConstraints x r@record { noConstraints = true  } = R'.noConstraints (x r)

applyExtContext : Telescope → R.TC A → R.TC A
applyExtContext [] x       = x
applyExtContext (t ∷ ts) x = applyExtContext ts $ (uncurry R.extendContext) t x

liftTC : R.TC A → TC A
liftTC x = λ r → applyExtContext (r .TCEnv.localContext) x

liftTC1 : (A → R.TC B) → A → TC B
liftTC1 f a = liftTC (f a)

liftTC2 : (A → B → R.TC C) → A → B → TC C
liftTC2 f a b = liftTC (f a b)

liftTC3 : (A → B → C → R.TC D) → A → B → C → TC D
liftTC3 f a b c = liftTC (f a b c)

module MonadTCI where
  unify             : Term → Term → TC ⊤
  unify             = applyNoConstraints ∘₂ liftTC2 R.unify

  typeError         : List ErrorPart → TC A
  typeError         = liftTC1 R.typeError

  inferType         : Term → TC Type
  inferType         = applyReconstruction ∘ applyNormalisation ∘ liftTC1 R.inferType

  checkType         : Term → Type → TC Term
  checkType         = (applyReconstruction ∘ applyNormalisation) ∘₂ liftTC2 R.checkType

  normalise         : Term → TC Term
  normalise         = applyReductionOptions ∘ applyReconstruction ∘ liftTC1 R.normalise

  reduce            : Term → TC Term
  reduce            = applyReductionOptions ∘ applyReconstruction ∘ liftTC1 R.reduce

  quoteTC           : A → TC Term
  quoteTC           = applyNormalisation ∘ liftTC1 R.quoteTC

  unquoteTC         : Term → TC A
  unquoteTC         = liftTC1 R.unquoteTC

  quoteωTC          : ∀ {A : Setω} → A → TC Term
  quoteωTC          = λ a → liftTC (R'.quoteωTC a)

  freshName         : String → TC Name
  freshName         = liftTC1 R.freshName

  declareDef        : Arg Name → Type → TC ⊤
  declareDef        = liftTC2 R.declareDef

  declarePostulate  : Arg Name → Type → TC ⊤
  declarePostulate  = liftTC2 R.declarePostulate

  defineFun         : Name → List Clause → TC ⊤
  defineFun         = liftTC2 R.defineFun

  getType           : Name → TC Type
  getType           = applyReconstruction ∘ liftTC1 R.getType

  getDefinition     : Name → TC Definition
  getDefinition     = applyReconstruction ∘ liftTC1 R.getDefinition

  blockOnMeta       : Meta → TC A
  blockOnMeta       = liftTC1 R.blockOnMeta

  commitTC          : TC ⊤
  commitTC          = liftTC R.commitTC

  isMacro           : Name → TC Bool
  isMacro           = liftTC1 R.isMacro

  debugPrint        : String → ℕ → List ErrorPart → TC ⊤
  debugPrint        = liftTC3 R.debugPrint

  runSpeculative    : TC (A × Bool) → TC A
  runSpeculative    = R.runSpeculative ∘_

  getInstances      : Meta → TC (List Term)
  getInstances      = liftTC1 R'.getInstances

MonadTC-TCI : MonadTC TC ⦃ Monad-TC ⦄ ⦃ MonadError-TC ⦄
MonadTC-TCI = record { MonadTCI }