|
|
|
@ -23,15 +23,13 @@ import Data.Foldable |
|
|
|
import Data.IORef |
|
|
|
import Data.Maybe |
|
|
|
|
|
|
|
import Elab.Eval.Formula |
|
|
|
import {>n class="err">-# SOURCE #-} Elab.Eval.Formula |
|
|
|
import Elab.Monad |
|
|
|
|
|
|
|
import GHC.Stack |
|
|
|
|
|
|
|
import Presyntax.Presyntax (Plicity(..)) |
|
|
|
|
|
|
|
import Prettyprinter |
|
|
|
|
|
|
|
import Syntax.Pretty |
|
|
|
import Syntax |
|
|
|
|
|
|
|
@ -42,7 +40,6 @@ import {-# SOURCE #-} Elab.WiredIn |
|
|
|
eval :: HasCallStack => Term -> ElabM Value |
|
|
|
eval t = asks (flip eval' t) |
|
|
|
|
|
|
|
-- everywhere force |
|
|
|
zonkIO :: Value -> IO Value |
|
|
|
zonkIO (VNe hd sp) = do |
|
|
|
sp' <- traverse zonkSp sp |
|
|
|
@ -64,7 +61,6 @@ zonkIO (VPair a b) = VPair <$> zonkIO a <*> zonkIO b |
|
|
|
zonkIO (VPath line x y) = VPath <$> zonkIO line <*> zonkIO x <*> zonkIO y |
|
|
|
zonkIO (VLine line x y f) = VLine <$> zonkIO line <*> zonkIO x <*> zonkIO y <*> zonkIO f |
|
|
|
|
|
|
|
-- Sorts |
|
|
|
zonkIO VType = pure VType |
|
|
|
zonkIO VTypeω = pure VTypeω |
|
|
|
|
|
|
|
@ -127,17 +123,17 @@ eval' env (App p f x) = vApp p (eval' env f) (eval' env x) |
|
|
|
|
|
|
|
eval' env (Lam p s t) = |
|
|
|
VLam p $ Closure s $ \a -> |
|
|
|
eval' env { getEnv = Map.insert s (error ("type of abs " ++ show (pretty (Lam p s t))), a) (getEnv env) } t |
|
|
|
eval' env { getEnv = Map.insert s (idkT, a) (getEnv env) } t |
|
|
|
|
|
|
|
eval' env (Pi p s d t) = |
|
|
|
VPi p (eval' env d) $ Closure s $ \a -> |
|
|
|
eval' env { getEnv = (Map.insert s (error "type of abs", a) (getEnv env))} t |
|
|
|
eval' env { getEnv = (Map.insert s (idkT, a) (getEnv env))} t |
|
|
|
|
|
|
|
eval' _ (Meta m) = VNe (HMeta m) mempty |
|
|
|
|
|
|
|
eval' env (Sigma s d t) = |
|
|
|
VSigma (eval' env d) $ Closure s $ \a -> |
|
|
|
eval' env { getEnv = Map.insert s (error "type of abs", a) (getEnv env) } t |
|
|
|
eval' env { getEnv = Map.insert s (idkT, a) (getEnv env) } t |
|
|
|
|
|
|
|
eval' e (Pair a b) = VPair (eval' e a) (eval' e b) |
|
|
|
|
|
|
|
@ -187,6 +183,13 @@ eval' e (Syntax.Refl a x) = VReflStrict (eval' e a) (eval' e x) |
|
|
|
eval' e (Syntax.AxK a x p pr eq) = strictK (eval' e a) (eval' e x) (eval' e p) (eval' e pr) (eval' e eq) |
|
|
|
eval' e (Syntax.AxJ a x p pr y eq) = strictJ (eval' e a) (eval' e x) (eval' e p) (eval' e pr) (eval' e y) (eval' e eq) |
|
|
|
|
|
|
|
idkT :: NFType |
|
|
|
idkT = VVar (Defined (T.pack "dunno") (negate 1)) |
|
|
|
|
|
|
|
isIdkT :: NFType -> Bool |
|
|
|
isIdkT (VVar (Defined (T.unpack -> "dunno") (negate -> 1))) = True |
|
|
|
isIdkT _ = False |
|
|
|
|
|
|
|
evalCase :: ElabEnv -> (Value -> Value) -> Value -> [(Term, Int, Term)] -> Value |
|
|
|
evalCase env rng sc [] = VCase (getEnv env) (fun rng) sc [] |
|
|
|
|
|
|
|
@ -214,7 +217,7 @@ evalCase env rng (val@(VNe (HPCon _ _ x) sp)) ((Con x', _, k):xs) |
|
|
|
evalCase env rng sc xs = VCase (getEnv env) (fun rng) sc xs |
|
|
|
|
|
|
|
evalFix' :: HasCallStack => ElabEnv -> Name -> NFType -> Term -> Value |
|
|
|
evalFix' env name nft term = fix $ \val -> eval' env{ getEnv = Map.insert name (nft, val) (getEnv env) } term |
|
|
|
evalFix' env name nft term = fix $ \val -> eval' env{ getEnv = Map.insert name (nft, GluedVl (HVar name) mempty val) (getEnv env) } term |
|
|
|
|
|
|
|
evalFix :: HasCallStack => Name -> NFType -> Term -> ElabM Value |
|
|
|
evalFix name nft term = do |
|
|
|
@ -225,6 +228,10 @@ data NotEqual = NotEqual Value Value |
|
|
|
deriving (Show, Typeable, Exception) |
|
|
|
|
|
|
|
unify' :: HasCallStack => Value -> Value -> ElabM () |
|
|
|
unify' (GluedVl h sp a) (GluedVl h' sp' b) |
|
|
|
| h == h', length sp == length sp' = |
|
|
|
traverse_ (uncurry unify'Spine) (Seq.zip sp sp') |
|
|
|
`catchElab` \(_ :: SomeException) -> unify' a b |
|
|
|
unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where |
|
|
|
go (VNe (HMeta mv) sp) rhs = solveMeta mv sp rhs |
|
|
|
go rhs (VNe (HMeta mv) sp) = solveMeta mv sp rhs |
|
|
|
@ -234,10 +241,10 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where |
|
|
|
go (VNe (HPCon s _ _) _) rhs | Just v <- trivialSystem s = go v rhs |
|
|
|
go lhs (VNe (HPCon s _ _) _) | Just v <- trivialSystem s = go lhs v |
|
|
|
|
|
|
|
go (VCase e _ a b) (VCase e' _ a' b') = do |
|
|
|
go (VCase e _ _ b) (VCase e' _ _ b') = do |
|
|
|
env <- ask |
|
|
|
unify' a a' |
|
|
|
let go (_, _, a) (_, _, b) = unify' (eval' env{getEnv=e} a) (eval' env{getEnv=e'} b) |
|
|
|
let |
|
|
|
go (_, _, a) (_, _, b) = unify' (eval' env{getEnv=moreDefinedFrom e e' <$> e} a) (eval' env{getEnv=moreDefinedFrom e e' <$> e'} b) |
|
|
|
zipWithM_ go (sortOn (\(x, _, _) -> x) b) (sortOn (\(x, _, _) -> x) b') |
|
|
|
|
|
|
|
go (VCase e _ _ b) y = do |
|
|
|
@ -264,13 +271,13 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where |
|
|
|
go (VPair a b) vl = unify' a (vProj1 vl) *> unify' b (vProj2 vl) |
|
|
|
go vl (VPair a b) = unify' (vProj1 vl) a *> unify' (vProj2 vl) b |
|
|
|
|
|
|
|
go (VPi p d (Closure _ k)) (VPi p' d' (Closure _ k')) | p == p' = do |
|
|
|
t <- VVar <$> newName |
|
|
|
go (VPi p d (Closure n k)) (VPi p' d' (Closure _ k')) | p == p' = do |
|
|
|
t <- VVar <$> newName' n |
|
|
|
unify' d d' |
|
|
|
unify' (k t) (k' t) |
|
|
|
|
|
|
|
go (VSigma d (Closure _ k)) (VSigma d' (Closure _ k')) = do |
|
|
|
t <- VVar <$> newName |
|
|
|
go (VSigma d (Closure n k)) (VSigma d' (Closure _ k')) = do |
|
|
|
t <- VVar <$> newName' n |
|
|
|
unify' d d' |
|
|
|
unify' (k t) (k' t) |
|
|
|
|
|
|
|
@ -285,7 +292,7 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where |
|
|
|
unify' y y' |
|
|
|
|
|
|
|
go (VLine l x y p) p' = do |
|
|
|
n <- VVar <$> newName |
|
|
|
n <- VVar <$> newName' (Bound (T.singleton 'i') (- 1)) |
|
|
|
unify' (p @@ n) (ielim l x y p' n) |
|
|
|
|
|
|
|
go p' (VLine l x y p) = do |
|
|
|
@ -301,6 +308,9 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where |
|
|
|
go (VComp a phi u a0) (VComp a' phi' u' a0') = |
|
|
|
traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u'), (a0, a0')] |
|
|
|
|
|
|
|
go (VHComp a phi u a0) (VHComp a' phi' u' a0') = |
|
|
|
traverse_ (uncurry unify') [(a, a'), (phi, phi'), (u, u'), (a0, a0')] |
|
|
|
|
|
|
|
go (VGlueTy _ (force -> VI1) u _0) rhs = unify' (u @@ VReflStrict VI VI1) rhs |
|
|
|
go lhs (VGlueTy _ (force -> VI1) u _0) = unify' lhs (u @@ VReflStrict VI VI1) |
|
|
|
|
|
|
|
@ -343,6 +353,19 @@ unify' topa topb = join $ go <$> forceIO topa <*> forceIO topb where |
|
|
|
| compareDNFs x y = pure () |
|
|
|
| otherwise = fail |
|
|
|
|
|
|
|
moreDefinedFrom :: Map Name (NFType, Value) -> Map Name (NFType, Value) -> (NFType, Value) -> (NFType, Value) |
|
|
|
moreDefinedFrom map1 map2 ours@(_, VNe (HVar name) _) = |
|
|
|
case Map.lookup name map1 of |
|
|
|
Just (_, VNe HVar{} _) -> map2's |
|
|
|
Just (ty, x) -> (ty, x) |
|
|
|
Nothing -> map2's |
|
|
|
where |
|
|
|
map2's = case Map.lookup name map2 of |
|
|
|
Just (_, VNe HVar{} _) -> ours |
|
|
|
Just (ty, x) -> (ty, x) |
|
|
|
Nothing -> ours |
|
|
|
moreDefinedFrom _ _ ours = ours |
|
|
|
|
|
|
|
trivialSystem :: Value -> Maybe Value |
|
|
|
trivialSystem = go . force where |
|
|
|
go VSystem{} = Nothing |
|
|
|
@ -400,25 +423,32 @@ isConvertibleTo a b = isConvertibleTo (force a) (force b) where |
|
|
|
unify' a b |
|
|
|
pure id |
|
|
|
|
|
|
|
newMeta :: Value -> ElabM Value |
|
|
|
newMeta dom = do |
|
|
|
newMeta' :: Bool -> Value -> ElabM Value |
|
|
|
newMeta' int dom = do |
|
|
|
loc <- liftM2 (,) <$> asks currentFile <*> asks currentSpan |
|
|
|
n <- newName |
|
|
|
c <- liftIO $ newIORef Nothing |
|
|
|
let m = MV (getNameText n) c dom (flatten <$> loc) |
|
|
|
let m = MV (getNameText n) c dom (flatten <$> loc) int |
|
|
|
flatten (x, (y, z)) = (x, y, z) |
|
|
|
|
|
|
|
env <- asks getEnv |
|
|
|
|
|
|
|
t <- for (Map.toList env) $ \(n, _) -> pure $ |
|
|
|
t <- fmap catMaybes . for (Map.toList env) $ \(n, t) -> pure $ |
|
|
|
case n of |
|
|
|
Bound{} -> Just (PApp Ex (VVar n)) |
|
|
|
Bound{} -> Just (PApp Ex (VVar n), n, t) |
|
|
|
_ -> Nothing |
|
|
|
|
|
|
|
let |
|
|
|
ts = Map.fromList $ fmap (\(_, n, (t, _)) -> (n, t)) t |
|
|
|
t' = fmap (\(x, _, _) -> x) t |
|
|
|
|
|
|
|
um <- asks unsolvedMetas |
|
|
|
liftIO . atomicModifyIORef um $ \um -> (Map.insert m [] um, ()) |
|
|
|
liftIO . atomicModifyIORef um $ \um -> (Map.insert (m ts) [] um, ()) |
|
|
|
|
|
|
|
pure (VNe (HMeta m) (Seq.fromList (catMaybes t))) |
|
|
|
pure (VNe (HMeta (m ts)) (Seq.fromList t')) |
|
|
|
|
|
|
|
newMeta :: Value -> ElabM Value |
|
|
|
newMeta = newMeta' False |
|
|
|
|
|
|
|
newName :: MonadIO m => m Name |
|
|
|
newName = liftIO $ do |
|
|
|
@ -435,27 +465,32 @@ _nameCounter = unsafePerformIO $ newIORef 0 |
|
|
|
{-# NOINLINE _nameCounter #-} |
|
|
|
|
|
|
|
solveMeta :: MV -> Seq Projection -> Value -> ElabM () |
|
|
|
solveMeta m Seq.Empty (VNe (HMeta m') Seq.Empty) | m == m' = pure () |
|
|
|
solveMeta m@(mvCell -> cell) sp rhs = do |
|
|
|
env <- ask |
|
|
|
names <- tryElab $ checkSpine Set.empty sp |
|
|
|
case names of |
|
|
|
Right names -> do |
|
|
|
checkScope (Set.fromList names) rhs |
|
|
|
`withNote` hsep [prettyTm (quote (VNe (HMeta m) sp)), pretty '≡', prettyTm (quote rhs)] |
|
|
|
let tm = quote rhs |
|
|
|
lam = eval' env $ foldr (Lam Ex) tm names |
|
|
|
liftIO . atomicModifyIORef (unsolvedMetas env) $ \mp -> (Map.delete m mp, ()) |
|
|
|
liftIO . atomicModifyIORef' cell $ \case |
|
|
|
Just _ -> error "filled cell in solvedMeta" |
|
|
|
Nothing -> (Just lam, ()) |
|
|
|
Left (_ :: SpineProjection) -> do |
|
|
|
scope <- tryElab $ checkScope m (Set.fromList names) rhs |
|
|
|
case scope of |
|
|
|
Right () -> do |
|
|
|
let tm = quote rhs |
|
|
|
lam = eval' env $ foldr (Lam Ex) tm names |
|
|
|
liftIO . atomicModifyIORef (unsolvedMetas env) $ \mp -> (Map.delete m mp, ()) |
|
|
|
liftIO . atomicModifyIORef' cell $ \case |
|
|
|
Just _ -> error "filled cell in solvedMeta" |
|
|
|
Nothing -> (Just lam, ()) |
|
|
|
Left (_ :: MetaException) -> abort env |
|
|
|
Left (_ :: MetaException) -> abort env |
|
|
|
where |
|
|
|
abort env = |
|
|
|
liftIO . atomicModifyIORef' (unsolvedMetas env) $ \x -> (, ()) $ |
|
|
|
case Map.lookup m x of |
|
|
|
Just qs -> Map.insert m ((sp, rhs):qs) x |
|
|
|
Nothing -> Map.insert m [(sp, rhs)] x |
|
|
|
|
|
|
|
checkScope :: Set Name -> Value -> ElabM () |
|
|
|
checkScope scope (VNe h sp) = |
|
|
|
checkScope :: MV -> Set Name -> Value -> ElabM () |
|
|
|
checkScope mv scope (VNe h sp) = |
|
|
|
do |
|
|
|
case h of |
|
|
|
HVar v@Bound{} -> |
|
|
|
@ -464,65 +499,65 @@ checkScope scope (VNe h sp) = |
|
|
|
HVar{} -> pure () |
|
|
|
HCon{} -> pure () |
|
|
|
HPCon{} -> pure () |
|
|
|
HMeta{} -> pure () |
|
|
|
HMeta m' -> when (mv == m') $ throwElab $ CircularSolution mv |
|
|
|
HData{} -> pure () |
|
|
|
traverse_ checkProj sp |
|
|
|
where |
|
|
|
checkProj (PApp _ t) = checkScope scope t |
|
|
|
checkProj (PIElim l x y i) = traverse_ (checkScope scope) [l, x, y, i] |
|
|
|
checkProj (PK l x y i) = traverse_ (checkScope scope) [l, x, y, i] |
|
|
|
checkProj (PJ l x y i j) = traverse_ (checkScope scope) [l, x, y, i, j] |
|
|
|
checkProj (POuc a phi u) = traverse_ (checkScope scope) [a, phi, u] |
|
|
|
checkProj (PApp _ t) = checkScope mv scope t |
|
|
|
checkProj (PIElim l x y i) = traverse_ (checkScope mv scope) [l, x, y, i] |
|
|
|
checkProj (PK l x y i) = traverse_ (checkScope mv scope) [l, x, y, i] |
|
|
|
checkProj (PJ l x y i j) = traverse_ (checkScope mv scope) [l, x, y, i, j] |
|
|
|
checkProj (POuc a phi u) = traverse_ (checkScope mv scope) [a, phi, u] |
|
|
|
checkProj PProj1 = pure () |
|
|
|
checkProj PProj2 = pure () |
|
|
|
|
|
|
|
checkScope scope (GluedVl _ _p vl) = checkScope scope vl |
|
|
|
checkScope mv scope (GluedVl _ _p vl) = checkScope mv scope vl |
|
|
|
|
|
|
|
checkScope scope (VLam _ (Closure n k)) = |
|
|
|
checkScope (Set.insert n scope) (k (VVar n)) |
|
|
|
checkScope mv scope (VLam _ (Closure n k)) = |
|
|
|
checkScope mv (Set.insert n scope) (k (VVar n)) |
|
|
|
|
|
|
|
checkScope scope (VPi _ d (Closure n k)) = do |
|
|
|
checkScope scope d |
|
|
|
checkScope (Set.insert n scope) (k (VVar n)) |
|
|
|
checkScope mv scope (VPi _ d (Closure n k)) = do |
|
|
|
checkScope mv scope d |
|
|
|
checkScope mv (Set.insert n scope) (k (VVar n)) |
|
|
|
|
|
|
|
checkScope scope (VSigma d (Closure n k)) = do |
|
|
|
checkScope scope d |
|
|
|
checkScope (Set.insert n scope) (k (VVar n)) |
|
|
|
checkScope mv scope (VSigma d (Closure n k)) = do |
|
|
|
checkScope mv scope d |
|
|
|
checkScope mv (Set.insert n scope) (k (VVar n)) |
|
|
|
|
|
|
|
checkScope s (VPair a b) = traverse_ (checkScope s) [a, b] |
|
|
|
checkScope mv s (VPair a b) = traverse_ (checkScope mv s) [a, b] |
|
|
|
|
|
|
|
checkScope _ VType = pure () |
|
|
|
checkScope _ VTypeω = pure () |
|
|
|
checkScope _ _ VType = pure () |
|
|
|
checkScope _ _ VTypeω = pure () |
|
|
|
|
|
|
|
checkScope _ VI = pure () |
|
|
|
checkScope _ VI0 = pure () |
|
|
|
checkScope _ VI1 = pure () |
|
|
|
checkScope _ _ VI = pure () |
|
|
|
checkScope _ _ VI0 = pure () |
|
|
|
checkScope _ _ VI1 = pure () |
|
|
|
|
|
|
|
checkScope s (VIAnd x y) = traverse_ (checkScope s) [x, y] |
|
|
|
checkScope s (VIOr x y) = traverse_ (checkScope s) [x, y] |
|
|
|
checkScope s (VINot x) = checkScope s x |
|
|
|
checkScope mv s (VIAnd x y) = traverse_ (checkScope mv s) [x, y] |
|
|
|
checkScope mv s (VIOr x y) = traverse_ (checkScope mv s) [x, y] |
|
|
|
checkScope mv s (VINot x) = checkScope mv s x |
|
|
|
|
|
|
|
checkScope s (VPath line a b) = traverse_ (checkScope s) [line, a, b] |
|
|
|
checkScope s (VLine _ _ _ line) = checkScope s line |
|
|
|
checkScope mv s (VPath line a b) = traverse_ (checkScope mv s) [line, a, b] |
|
|
|
checkScope mv s (VLine _ _ _ line) = checkScope mv s line |
|
|
|
|
|
|
|
checkScope s (VPartial x y) = traverse_ (checkScope s) [x, y] |
|
|
|
checkScope s (VPartialP x y) = traverse_ (checkScope s) [x, y] |
|
|
|
checkScope s (VSystem fs) = |
|
|
|
for_ (Map.toList fs) $ \(x, y) -> traverse_ (checkScope s) [x, y] |
|
|
|
checkScope mv s (VPartial x y) = traverse_ (checkScope mv s) [x, y] |
|
|
|
checkScope mv s (VPartialP x y) = traverse_ (checkScope mv s) [x, y] |
|
|
|
checkScope mv s (VSystem fs) = |
|
|
|
for_ (Map.toList fs) $ \(x, y) -> traverse_ (checkScope mv s) [x, y] |
|
|
|
|
|
|
|
checkScope s (VSub a b c) = traverse_ (checkScope s) [a, b, c] |
|
|
|
checkScope s (VInc a b c) = traverse_ (checkScope s) [a, b, c] |
|
|
|
checkScope s (VComp a phi u a0) = traverse_ (checkScope s) [a, phi, u, a0] |
|
|
|
checkScope s (VHComp a phi u a0) = traverse_ (checkScope s) [a, phi, u, a0] |
|
|
|
checkScope mv s (VSub a b c) = traverse_ (checkScope mv s) [a, b, c] |
|
|
|
checkScope mv s (VInc a b c) = traverse_ (checkScope mv s) [a, b, c] |
|
|
|
checkScope mv s (VComp a phi u a0) = traverse_ (checkScope mv s) [a, phi, u, a0] |
|
|
|
checkScope mv s (VHComp a phi u a0) = traverse_ (checkScope mv s) [a, phi, u, a0] |
|
|
|
|
|
|
|
checkScope s (VGlueTy a phi ty eq) = traverse_ (checkScope s) [a, phi, ty, eq] |
|
|
|
checkScope s (VGlue a phi ty eq inv x) = traverse_ (checkScope s) [a, phi, ty, eq, inv, x] |
|
|
|
checkScope s (VUnglue a phi ty eq vl) = traverse_ (checkScope s) [a, phi, ty, eq, vl] |
|
|
|
checkScope mv s (VGlueTy a phi ty eq) = traverse_ (checkScope mv s) [a, phi, ty, eq] |
|
|
|
checkScope mv s (VGlue a phi ty eq inv x) = traverse_ (checkScope mv s) [a, phi, ty, eq, inv, x] |
|
|
|
checkScope mv s (VUnglue a phi ty eq vl) = traverse_ (checkScope mv s) [a, phi, ty, eq, vl] |
|
|
|
|
|
|
|
checkScope s (VCase _ _ v _) = checkScope s v |
|
|
|
checkScope mv s (VCase _ _ v _) = checkScope mv s v |
|
|
|
|
|
|
|
checkScope s (VEqStrict a x y) = traverse_ (checkScope s) [a, x, y] |
|
|
|
checkScope s (VReflStrict a x) = traverse_ (checkScope s) [a, x] |
|
|
|
checkScope mv s (VEqStrict a x y) = traverse_ (checkScope mv s) [a, x, y] |
|
|
|
checkScope mv s (VReflStrict a x) = traverse_ (checkScope mv s) [a, x] |
|
|
|
|
|
|
|
checkSpine :: Set Name -> Seq Projection -> ElabM [Name] |
|
|
|
checkSpine scope (PApp Ex (VVar n@Bound{}) Seq.:<| xs) |
|
|
|
@ -531,10 +566,7 @@ checkSpine scope (PApp Ex (VVar n@Bound{}) Seq.:<| xs) |
|
|
|
checkSpine _ (p Seq.:<| _) = throwElab $ SpineProj p |
|
|
|
checkSpine _ Seq.Empty = pure [] |
|
|
|
|
|
|
|
newtype NonLinearSpine = NonLinearSpine { getDupeName :: Name } |
|
|
|
deriving (Show, Typeable, Exception) |
|
|
|
|
|
|
|
newtype SpineProjection = SpineProj { getSpineProjection :: Projection } |
|
|
|
data MetaException = NonLinearSpine { getDupeName :: Name } | SpineProj { getSpineProjection :: Projection } | CircularSolution { getCycle :: MV } |
|
|
|
deriving (Show, Typeable, Exception) |
|
|
|
|
|
|
|
substituteIO :: Map.Map Name Value -> Value -> IO Value |
|
|
|
@ -563,7 +595,6 @@ substituteIO sub = substituteIO . force where |
|
|
|
substituteIO (VPath line x y) = VPath <$> substituteIO line <*> substituteIO x <*> substituteIO y |
|
|
|
substituteIO (VLine line x y f) = VLine <$> substituteIO line <*> substituteIO x <*> substituteIO y <*> substituteIO f |
|
|
|
|
|
|
|
-- Sorts |
|
|
|
substituteIO VType = pure VType |
|
|
|
substituteIO VTypeω = pure VTypeω |
|
|
|
|
|
|
|
@ -655,6 +686,7 @@ vApp p (VSystem fs) arg = mkVSystem (fmap (flip (vApp p) arg) fs) |
|
|
|
vApp p (VCase env rng sc branches) arg = |
|
|
|
VCase env (fun \x -> let VPi _ _ (Closure _ r) = rng @@ x in r arg) sc |
|
|
|
(map (projIntoCase (flip (App p) (quote arg))) branches) |
|
|
|
-- vApp _ (VLine _ _ _ (VLam _ k)) arg = clCont k arg |
|
|
|
vApp _ x _ = error $ "can't apply " ++ show (prettyTm (quote x)) |
|
|
|
|
|
|
|
(@@) :: HasCallStack => Value -> Value -> Value |
|
|
|
|
