cubical/src/Elab.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Elab where

import Control.Monad.Reader
import Control.Exception

import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Traversable
import Data.Typeable
import Data.Foldable

import Elab.Eval.Formula (possible, truthAssignments)
import Elab.WiredIn
import Elab.Monad
import Elab.Eval

import qualified Presyntax.Presyntax as P

import Prettyprinter

import Syntax.Pretty
import Syntax
import Data.Map (Map)
import Data.Text (Text)

infer :: P.Expr -> ElabM (Term, NFType)
infer (P.Span ex a b) = withSpan a b $ infer ex

infer (P.Var t) = do
  name <- getNameFor t
  nft <- getNfType name
  pure (Ref name, nft)

infer (P.App p f x) = do
  (f, f_ty) <- infer f
  porp <- isPiType p f_ty
  case porp of
    It'sProd d r w -> do
      x <- check x d
      x_nf <- eval x
      pure (App p (w f) x, r x_nf)
    It'sPath li le ri wp -> do
      x <- check x VI
      x_nf <- eval x
      pure (IElim (quote (fun li)) (quote le) (quote ri) (wp f) x, li x_nf)
    It'sPartial phi a w -> do
      x <- check x (VIsOne phi)
      pure (App P.Ex (w f) x, a)
    It'sPartialP phi a w -> do
      x <- check x (VIsOne phi)
      x_nf <- eval x
      pure (App P.Ex (w f) x, a @@ x_nf)

infer (P.Proj1 x) = do
  (tm, ty) <- infer x
  (d, _, wp) <- isSigmaType ty
  pure (Proj1 (wp tm), d)

infer (P.Proj2 x) = do
  (tm, ty) <- infer x
  tm_nf <- eval tm
  (_, r, wp) <- isSigmaType ty
  pure (Proj2 (wp tm), r (vProj1 tm_nf))

infer exp = do
  t <- newMeta VType
  tm <- switch $ check exp t
  pure (tm, t)

check :: P.Expr -> NFType -> ElabM Term
check (P.Span ex a b) ty = withSpan a b $ check ex ty

check (P.Lam p var body) (VPi p' dom (Closure _ rng)) | p == p' =
  assume (Bound var 0) dom $ \name ->
    Lam p name <$> check body (rng (VVar name))

check tm (VPi P.Im dom (Closure var rng)) =
  assume var dom $ \name ->
    Lam P.Im name <$> check tm (rng (VVar name))

check (P.Lam p v b) ty = do
  porp <- isPiType p =<< forceIO ty
  case porp of
    It'sProd d r wp ->
      assume (Bound v 0) d $ \name ->
        wp . Lam p name <$> check b (r (VVar name))

    It'sPath li le ri wp -> do
      tm <- assume (Bound v 0) VI $ \var ->
        Lam P.Ex var <$> check b (force (li (VVar var)))

      tm_nf <- eval tm

      unify (tm_nf @@ VI0) le
        `catchElab` (throwElab . WhenCheckingEndpoint le ri VI0)

      unify (tm_nf @@ VI1) ri
        `catchElab` (throwElab . WhenCheckingEndpoint le ri VI1)

      pure (wp (PathIntro (quote (fun li)) (quote le) (quote ri) tm))

    It'sPartial phi a wp ->
      assume (Bound v 0) (VIsOne phi) $ \var ->
        wp . Lam p var <$> check b a

    It'sPartialP phi a wp ->
      assume (Bound v 0) (VIsOne phi) $ \var ->
        wp . Lam p var <$> check b (a @@ VVar var)

check (P.Pair a b) ty = do
  (d, r, wp) <- isSigmaType =<< forceIO ty
  a <- check a d
  a_nf <- eval a
  b <- check b (r a_nf)
  pure (wp (Pair a b))

check (P.Pi p s d r) ty = do
  isSort ty
  d <- check d ty
  d_nf <- eval d
  assume (Bound s 0) d_nf \var -> do
    r <- check r ty
    pure (Pi p var d r)

check (P.Sigma s d r) ty = do
  isSort ty
  d <- check d ty
  d_nf <- eval d
  assume (Bound s 0) d_nf \var -> do
    r <- check r ty
    pure (Sigma var d r)

check (P.Let items body) ty = do
  checkLetItems mempty items \decs -> do
    body <- check body ty
    pure (Let decs body)

check (P.LamSystem bs) ty = do
  (extent, dom) <- isPartialType ty
  let dom_q = quote dom
  eqns <- for (zip [(0 :: Int)..] bs) $ \(n, (formula, rhs)) -> do
    phi <- checkFormula (P.condF formula)
    rhses <-
        case P.condV formula of
          Just t -> assume (Bound t 0) (VIsOne phi) $ \var -> do
            env <- ask
            for (truthAssignments phi (getEnv env)) $ \e -> do
              let env' = env{ getEnv = e }
              (Just var,) <$> check rhs (eval' env' dom_q)
          Nothing -> do
            env <- ask
            for (truthAssignments phi (getEnv env)) $ \e -> do
              let env' = env{ getEnv = e }
              (Nothing,) <$> check rhs (eval' env' dom_q)
    pure (n, (phi, head rhses))

  unify extent (foldl ior VI0 (map (fst . snd) eqns))

  for_ eqns $ \(n, (formula, (binding, rhs))) -> do
    let
      k = case binding of
        Just v -> assume v (VIsOne formula) . const
        Nothing -> id
    k $ for_ eqns $ \(n', (formula', (binding, rhs'))) -> do
      let
        k = case binding of
          Just v -> assume v (VIsOne formula) . const
          Nothing -> id
        truth = possible mempty (iand formula formula')
        add [] = id
        add ((~(HVar x), True):xs) = redefine x VI VI1 . add xs
        add ((~(HVar x), False):xs) = redefine x VI VI0 . add xs
      k $ when ((n /= n') && fst truth) . add (Map.toList (snd truth)) $ do
        vl <- eval rhs
        vl' <- eval rhs'
        unify vl vl'
          `withNote` vsep [ pretty "These two cases must agree because they are both possible:"
                          , indent 2 $ pretty '*' <+> prettyTm (quote formula) <+> operator (pretty "=>") <+> prettyTm rhs
                          , indent 2 $ pretty '*' <+> prettyTm (quote formula') <+> operator (pretty "=>") <+> prettyTm rhs'
                          ]
          `withNote` (pretty "Consider this face, where both are true:" <+> showFace (snd truth))

  name <- newName
  let
    mkB name (Just v, b) = App P.Ex (Lam P.Ex v b) (Ref name)
    mkB _ (Nothing, b) = b
  pure (Lam P.Ex name (System (Map.fromList (map (\(_, (x, y)) -> (quote x, mkB name y)) eqns))))

check exp ty = do
  (tm, has) <- switch $ infer exp
  wp <- isConvertibleTo has ty
  pure (wp tm)

checkLetItems :: Map Text (Maybe NFType) -> [P.LetItem] -> ([(Name, Term, Term)] -> ElabM a) -> ElabM a
checkLetItems _   [] cont = cont []
checkLetItems map (P.LetDecl v t:xs) cont = do
  t <- check t VTypeω
  t_nf <- eval t
  assume (Defined v 0) t_nf \_ ->
    checkLetItems (Map.insert v (Just t_nf) map) xs cont

checkLetItems map (P.LetBind name rhs:xs) cont = do
  case Map.lookup name map of
    Nothing -> do
      (tm, ty) <- infer rhs
      tm_nf <- eval tm
      define (Defined name 0) ty tm_nf \name' ->
        checkLetItems map xs \xs ->
          cont ((name', quote ty, tm):xs)
    Just Nothing -> throwElab $ Redefinition (Defined name 0)
    Just (Just ty_nf) -> do
      rhs <- check rhs ty_nf
      rhs_nf <- eval rhs
      define (Defined name 0) ty_nf rhs_nf \name' ->
        checkLetItems (Map.insert name Nothing map) xs \xs ->
          cont ((name', quote ty_nf, rhs):xs)

checkFormula :: P.Formula -> ElabM Value
checkFormula P.FTop = pure VI1
checkFormula P.FBot = pure VI0
checkFormula (P.FAnd x y) = iand <$> checkFormula x <*> checkFormula y
checkFormula (P.FOr x y) = ior <$> checkFormula x <*> checkFormula y
checkFormula (P.FIs0 x) = do
  nm <- getNameFor x
  ty <- getNfType nm
  unify ty VI
  pure (inot (VVar nm))
checkFormula (P.FIs1 x) = do
  nm <- getNameFor x
  ty <- getNfType nm
  unify ty VI
  pure (VVar nm)

isSort :: NFType -> ElabM ()
isSort t = isSort (force t) where
  isSort VType              = pure ()
  isSort VTypeω             = pure ()
  isSort vt@(VNe HMeta{} _) = unify vt VType
  isSort vt = throwElab $ NotEqual vt VType

data ProdOrPath
  = It'sProd { prodDmn  :: NFType
             , prodRng  :: NFType -> NFType
             , prodWrap :: Term -> Term
             }
  | It'sPath { pathLine  :: NFType -> NFType
             , pathLeft  :: Value
             , pathRight :: Value
             , pathWrap  :: Term -> Term
             }
  | It'sPartial { partialExtent :: NFEndp
                , partialDomain :: Value
                , partialWrap   :: Term -> Term
                }
  | It'sPartialP { partialExtent :: NFEndp
                 , partialDomain :: Value
                 , partialWrap   :: Term -> Term
                 }

isPiType :: P.Plicity -> NFType -> ElabM ProdOrPath
isPiType p x = isPiType p (force x) where
  isPiType p (VPi p' d (Closure _ k)) | p == p' = pure (It'sProd d k id)
  isPiType P.Ex (VPath li le ri) = pure (It'sPath (li @@) le ri id)
  isPiType P.Ex (VPartial phi a) = pure (It'sPartial phi a id)
  isPiType P.Ex (VPartialP phi a) = pure (It'sPartialP phi a id)

  isPiType P.Ex (VPi P.Im d (Closure _ k)) = do
    meta <- newMeta d
    porp <- isPiType P.Ex (k meta)
    pure $ case porp of
      It'sProd d r w -> It'sProd d r (\f -> w (App P.Im f (quote meta)))
      It'sPath l x y w -> It'sPath l x y (\f -> w (App P.Im f (quote meta)))
      It'sPartial phi a w -> It'sPartial phi a (\f -> w (App P.Im f (quote meta)))
      It'sPartialP phi a w -> It'sPartialP phi a (\f -> w (App P.Im f (quote meta)))
  isPiType p t = do
    dom <- newMeta VType
    name <- newName
    assume name dom $ \name -> do
      rng <- newMeta VType
      wp <- isConvertibleTo t (VPi p dom (Closure name (const rng)))
      pure (It'sProd dom (const rng) wp)

isSigmaType :: NFType -> ElabM (Value, NFType -> NFType, Term -> Term)
isSigmaType t = isSigmaType (force t) where
  isSigmaType (VSigma d (Closure _ k)) = pure (d, k, id)
  isSigmaType t = do
    dom <- newMeta VType
    name <- newName
    assume name dom $ \name -> do
      rng <- newMeta VType
      wp <- isConvertibleTo t (VSigma dom (Closure name (const rng)))
      pure (dom, const rng, wp)

isPartialType :: NFType -> ElabM (NFEndp, Value)
isPartialType t = isPartialType (force t) where
  isPartialType (VPartial phi a) = pure (phi, a)
  isPartialType (VPartialP phi a) = pure (phi, a)
  isPartialType t = do
    phi <- newMeta VI
    dom <- newMeta (VPartial phi VType)
    unify t (VPartial phi dom)
    pure (phi, dom)

checkStatement :: P.Statement -> ElabM a -> ElabM a
checkStatement (P.SpanSt s a b) k = withSpan a b $ checkStatement s k

checkStatement (P.Decl name ty) k = do
  ty <- check ty VTypeω
  ty_nf <- eval ty
  assumes (flip Defined 0 <$> name) ty_nf (const k)

checkStatement (P.Postulate []) k = k
checkStatement (P.Postulate ((name, ty):xs)) k = do
  ty <- check ty VTypeω
  ty_nf <- eval ty
  assume (Defined name 0) ty_nf \name ->
    local (\e -> e { definedNames = Set.insert name (definedNames e) }) (checkStatement (P.Postulate xs) k)

checkStatement (P.Defn name rhs) k = do
  ty <- asks (Map.lookup name . nameMap)
  case ty of
    Nothing -> do
      (tm, ty) <- infer rhs
      tm_nf <- eval tm
      define (Defined name 0) ty tm_nf (const k)
    Just nm -> do
      ty_nf <- getNfType nm
      t <- asks (Set.member nm . definedNames)
      when t $ throwElab (Redefinition (Defined name 0))

      rhs <- check rhs ty_nf
      rhs_nf <- eval rhs
      define (Defined name 0) ty_nf rhs_nf $ \name ->
        local (\e -> e { definedNames = Set.insert name (definedNames e) }) k

checkStatement (P.Builtin winame var) k = do
  wi <-
    case Map.lookup winame wiredInNames of
      Just wi -> pure wi
      _ -> throwElab $ NoSuchPrimitive winame

  let
    check = do
      nm <- getNameFor var
      ty <- getNfType nm
      unify ty (wiType wi)
        `withNote` hsep [ pretty "Previous definition of", pretty nm, pretty "here" ]
        `seeAlso` nm

  env <- ask
  liftIO $
    runElab check env `catch` \(_ :: NotInScope) -> pure ()

  define (Defined var 0) (wiType wi) (wiValue wi) $ \name ->
    local (\e -> e { definedNames = Set.insert name (definedNames e) }) k

checkStatement (P.ReplNf e) k = do
  (e, _) <- infer e
  e_nf <- eval e
  h <- asks commHook
  liftIO (h e_nf)
  k

checkStatement (P.ReplTy e) k = do
  (_, ty) <- infer e
  h <- asks commHook
  liftIO (h ty)
  k

checkProgram :: [P.Statement] -> ElabM a -> ElabM a
checkProgram [] k = k
checkProgram (st:sts) k = checkStatement st $ checkProgram sts k

newtype Redefinition = Redefinition { getRedefName :: Name }
  deriving (Show, Typeable, Exception)

data WhenCheckingEndpoint = WhenCheckingEndpoint { leftEndp :: Value, rightEndp :: Value, whichIsWrong :: NFEndp, exc :: SomeException }
  deriving (Show, Typeable, Exception)