A couple of other spots we expand to Case
This commit is contained in:
@@ -48,12 +48,22 @@ forceMeta (VMeta fc ix sp) = case !(lookupMeta ix) of
|
|||||||
(Solved k t) => vappSpine t sp >>= forceMeta
|
(Solved k t) => vappSpine t sp >>= forceMeta
|
||||||
forceMeta x = pure x
|
forceMeta x = pure x
|
||||||
|
|
||||||
|
tryEval : String -> SnocList Val -> M (Maybe Val)
|
||||||
|
tryEval k sp =
|
||||||
|
case lookup k !(get) of
|
||||||
|
Just (MkEntry name ty (Fn tm)) => do
|
||||||
|
vtm <- eval [] CBN tm
|
||||||
|
case !(vappSpine vtm sp) of
|
||||||
|
VCase{} => pure Nothing
|
||||||
|
v => pure $ Just v
|
||||||
|
_ => pure Nothing
|
||||||
|
|
||||||
-- Lennart needed more forcing for recursive nat,
|
-- Lennart needed more forcing for recursive nat,
|
||||||
forceType : Val -> M Val
|
forceType : Val -> M Val
|
||||||
forceType (VRef fc nm def sp) =
|
forceType tm@(VRef fc nm def sp) =
|
||||||
case lookup nm !(get) of
|
case !(tryEval nm sp) of
|
||||||
(Just (MkEntry name type (Fn t))) => vappSpine !(eval [] CBN t) sp
|
Just tm => pure tm
|
||||||
_ => pure (VRef fc nm def sp)
|
_ => pure tm
|
||||||
forceType (VMeta fc ix sp) = case !(lookupMeta ix) of
|
forceType (VMeta fc ix sp) = case !(lookupMeta ix) of
|
||||||
(Unsolved x k xs _) => pure (VMeta fc ix sp)
|
(Unsolved x k xs _) => pure (VMeta fc ix sp)
|
||||||
(Solved k t) => vappSpine t sp >>= forceType
|
(Solved k t) => vappSpine t sp >>= forceType
|
||||||
@@ -208,17 +218,12 @@ parameters (ctx: Context)
|
|||||||
if k == k' then do
|
if k == k' then do
|
||||||
debug "unify \{show l} spine at \{k} \{show sp} \{show sp'}"
|
debug "unify \{show l} spine at \{k} \{show sp} \{show sp'}"
|
||||||
unifySpine l (k == k') sp sp'
|
unifySpine l (k == k') sp sp'
|
||||||
else case lookup k !(get) of
|
else do
|
||||||
Just (MkEntry name ty (Fn tm)) => do
|
Nothing <- tryEval k sp
|
||||||
vtm <- eval [] CBN tm
|
| Just v => unify l v u'
|
||||||
v <- vappSpine vtm sp
|
Nothing <- tryEval k' sp'
|
||||||
unify l v u'
|
| Just v => unify l t' v
|
||||||
_ => case lookup k' !(get) of
|
error fc "vref mismatch \{show k} \{show k'} -- \{show sp} \{show sp'}"
|
||||||
Just (MkEntry name ty (Fn tm)) => do
|
|
||||||
vtm <- eval [] CBN tm
|
|
||||||
v <- vappSpine vtm sp'
|
|
||||||
unify l t' v
|
|
||||||
_ => error fc "vref mismatch \{show k} \{show k'} -- \{show sp} \{show sp'}"
|
|
||||||
|
|
||||||
(VU _, VU _) => pure neutral
|
(VU _, VU _) => pure neutral
|
||||||
-- Lennart.newt cursed type references itself
|
-- Lennart.newt cursed type references itself
|
||||||
|
|||||||
Reference in New Issue
Block a user