pi/src/Core/Normalize.idr

module Core.Normalize

import Core.Term
import Core.Value
import Core.Misc

import Control.Monad.RWS
import Control.Monad.Identity
import Control.Monad.Either

import Data.Nat
import Data.Vect
import Data.IOArray
import Data.IORef

%default total

mutual
  public export
  app : {auto deftrs : RefA DTR Value}
     -> {auto frst   : Ref  NST Nat}
     -> Value -> Value -> PI Value
  app (VClos env (TLam sc))       x = eval (x :: env) sc

  app (VClos env (TTopInd c st)) VTop = eval env st

  app (VClos env1 (TNatInd _ z s)) (VClos env2 TZero)      = eval env1 z
  app f@(VClos env1 (TNatInd _ z s)) (VClos env2 (TSuc n)) = assert_total $ do
    s' <- eval env1 s
    sn <- app (VClos env1 s) (VClos env2 n)
    app sn =<< app f (VClos env2 n)

  app (VClos env1 (TSigInd _ _ c f)) (VClos env2 (TPair a b)) = assert_total $ do
    f' <- eval env1 f
    fa <- app f' (VClos env2 a)
    app fa (VClos env2 b)

  app (VClos env (TJ _ _ _ _ d)) (VClos _ (TRefl _ _)) = eval env d

  app f x = pure (VApp f x)

  public export
  eval : {auto deftrs : RefA DTR Value}
      -> {auto frst   : Ref NST Nat} 
      -> Ctx n -> Term n -> PI Value
  eval env (TVar i)    = pure (index i env)
  eval env (TDef i)    = do
    res <- getArr DTR i
    case res of
         Just x  => pure x
         Nothing => oops "TDef term lookup"
  eval env TType       = pure VType
  eval env TTop        = pure VTop
  eval env TStar       = pure VStar
  eval env TBot        = pure VBot
  eval env TNat        = pure VNat
  eval env (TApp f x)  = do
    f' <- eval env f
    x' <- eval env x
    assert_total (app f' x') -- :(

  eval env (TLet ty tr tri) = do
    tr' <- eval env tr
    eval (tr' :: env) tri

  eval env tr         = pure (VClos env tr)

  public export
  whnf : {auto deftrs    : RefA DTR Value}
      -> {auto frst   : Ref  NST Nat} 
      -> Value -> PI Value
  whnf (VClos env tr) = eval env tr
  whnf (VApp f x) = do
    f' <- whnf f
    x' <- whnf x
    app f' x'
  whnf v              = pure v