dunham/newt
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

fix erasure issues inside where clauses (add type to LetRec)

Browse Source
This commit is contained in:
Steve Dunham
2024-12-06 20:55:16 -08:00
parent 8d8078f968
commit 0c0b1668d7
8 changed files with 29 additions and 36 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/Lib/Compile.idr
View File

@@ -328,7 +328,7 @@ process (done,docs) nm = do
walkTm (App x t u) acc = walkTm t !(walkTm u acc)
walkTm (Pi x str icit y t u) acc = walkTm t !(walkTm u acc)
walkTm (Let x str t u) acc = walkTm t !(walkTm u acc)
walkTm (LetRec x str t u) acc = walkTm t !(walkTm u acc)
walkTm (LetRec x str _ t u) acc = walkTm t !(walkTm u acc)
walkTm (Case x t alts) acc = foldlM walkAlt acc alts
walkTm _ acc = pure acc

2
src/Lib/CompileExp.idr
View File

@@ -143,7 +143,7 @@ compileTerm (Case _ t alts) = do
pure $ CCase t' alts'
compileTerm (Lit _ lit) = pure $ CLit lit
compileTerm (Let _ nm t u) = pure $ CLet nm !(compileTerm t) !(compileTerm u)
compileTerm (LetRec _ nm t u) = pure $ CLetRec nm !(compileTerm t) !(compileTerm u)
compileTerm (LetRec _ nm _ t u) = pure $ CLetRec nm !(compileTerm t) !(compileTerm u)
compileTerm (Erased _) = pure CErased
export

7
src/Lib/Elab.idr
View File

@@ -181,8 +181,9 @@ rename meta ren lvl v = go ren lvl v
go ren lvl (VLit fc lit) = pure (Lit fc lit)
go ren lvl (VLet fc name val body) =
pure $ Let fc name !(go ren lvl val) !(go (lvl :: ren) (S lvl) body)
go ren lvl (VLetRec fc name val body) =
pure $ Let fc name !(go (lvl :: ren) (S lvl) val) !(go (lvl :: ren) (S lvl) body)
-- these probably shouldn't show up in solutions...
go ren lvl (VLetRec fc name ty val body) =
pure $ LetRec fc name !(go ren lvl ty) !(go (lvl :: ren) (S lvl) val) !(go (lvl :: ren) (S lvl) body)
lams : Nat -> List String -> Tm -> Tm
lams 0 _ tm = tm
@@ -731,7 +732,7 @@ checkWhere ctx decls body ty = do
-- Should we run the rest with the definition in place?
-- I'm wondering if switching from bind to define will mess with metas
-- let ctx' = define ctx name vtm vty
pure $ LetRec sigFC name tm !(checkWhere ctx' decls' body ty)
pure $ LetRec sigFC name funTy tm !(checkWhere ctx' decls' body ty)
checkDone : Context -> List (String, Pattern) -> Raw -> Val -> M Tm

8
src/Lib/Erasure.idr
View File

@@ -77,10 +77,10 @@ erase env t sp = case t of
u' <- erase env u []
v' <- erase ((nm, Many, Nothing) :: env) v []
eraseSpine env (Let fc nm u' v') sp Nothing
(LetRec fc nm u v) => do
u' <- erase ((nm, Many, Nothing) :: env) u []
v' <- erase ((nm, Many, Nothing) :: env) v []
eraseSpine env (LetRec fc nm u' v') sp Nothing
(LetRec fc nm ty u v) => do
u' <- erase ((nm, Many, Just ty) :: env) u []
v' <- erase ((nm, Many, Just ty) :: env) v []
eraseSpine env (LetRec fc nm ty u' v') sp Nothing
(Bnd fc k) => do
case getAt k env of
Nothing => error fc "bad index \{show k}"

8
src/Lib/Eval.idr
View File

@@ -153,7 +153,7 @@ eval env mode (Meta fc i) =
eval env mode (Lam fc x icit rig t) = pure $ VLam fc x icit rig (MkClosure env t)
eval env mode (Pi fc x icit rig a b) = pure $ VPi fc x icit rig !(eval env mode a) (MkClosure env b)
eval env mode (Let fc nm t u) = pure $ VLet fc nm !(eval env mode t) !(eval (VVar fc (length env) [<] :: env) mode u)
eval env mode (LetRec fc nm t u) = pure $ VLetRec fc nm !(eval (VVar fc (length env) [<] :: env) mode t) !(eval (VVar fc (length env) [<] :: env) mode u)
eval env mode (LetRec fc nm ty t u) = pure $ VLetRec fc nm !(eval env mode ty) !(eval (VVar fc (length env) [<] :: env) mode t) !(eval (VVar fc (length env) [<] :: env) mode u)
-- Here, we assume env has everything. We push levels onto it during type checking.
-- I think we could pass in an l and assume everything outside env is free and
-- translate to a level
@@ -189,7 +189,7 @@ quote l (VMeta fc i sp) =
quote l (VLam fc x icit rig t) = pure $ Lam fc x icit rig !(quote (S l) !(t $$ VVar emptyFC l [<]))
quote l (VPi fc x icit rig a b) = pure $ Pi fc x icit rig !(quote l a) !(quote (S l) !(b $$ VVar emptyFC l [<]))
quote l (VLet fc nm t u) = pure $ Let fc nm !(quote l t) !(quote (S l) u)
quote l (VLetRec fc nm t u) = pure $ LetRec fc nm !(quote (S l) t) !(quote (S l) u)
quote l (VLetRec fc nm ty t u) = pure $ LetRec fc nm !(quote l ty) !(quote (S l) t) !(quote (S l) u)
quote l (VU fc) = pure (U fc)
quote l (VRef fc n def sp) = quoteSp l (Ref fc n def) sp
quote l (VCase fc sc alts) = pure $ Case fc !(quote l sc) alts
@@ -249,7 +249,7 @@ tweakFC fc (App fc1 t u) = App fc t u
tweakFC fc (Pi fc1 nm icit x t u) = Pi fc nm icit x t u
tweakFC fc (Case fc1 t xs) = Case fc t xs
tweakFC fc (Let fc1 nm t u) = Let fc nm t u
tweakFC fc (LetRec fc1 nm t u) = LetRec fc nm t u
tweakFC fc (LetRec fc1 nm ty t u) = LetRec fc nm ty t u
tweakFC fc (Lit fc1 lit) = Lit fc lit
tweakFC fc (Erased fc1) = Erased fc
@@ -282,7 +282,7 @@ zonk top l env t = case t of
(App fc t u) => zonkApp top l env t [!(zonk top l env u)]
(Pi fc nm icit rig a b) => Pi fc nm icit rig <$> zonk top l env a <*> zonkBind top l env b
(Let fc nm t u) => Let fc nm <$> zonk top l env t <*> zonkBind top l env u
(LetRec fc nm t u) => LetRec fc nm <$> zonkBind top l env t <*> zonkBind top l env u
(LetRec fc nm ty t u) => LetRec fc nm <$> zonk top l env ty <*> zonkBind top l env t <*> zonkBind top l env u
(Case fc sc alts) => Case fc <$> zonk top l env sc <*> traverse (zonkAlt top l env) alts
U fc => pure $ U fc
Lit fc lit => pure $ Lit fc lit

14
src/Lib/Types.idr
View File

@@ -125,7 +125,7 @@ data Tm : Type where
-- need type?
Let : FC -> Name -> Tm -> Tm -> Tm
-- for desugaring where
LetRec : FC -> Name -> Tm -> Tm -> Tm
LetRec : FC -> Name -> Tm -> Tm -> Tm -> Tm
Lit : FC -> Literal -> Tm
Erased : FC -> Tm
@@ -143,7 +143,7 @@ HasFC Tm where
getFC (Case fc t xs) = fc
getFC (Lit fc _) = fc
getFC (Let fc _ _ _) = fc
getFC (LetRec fc _ _ _) = fc
getFC (LetRec fc _ _ _ _) = fc
getFC (Erased fc) = fc
covering
@@ -169,7 +169,7 @@ Show Tm where
show (Pi _ str Auto rig t u) = "(Pi {{\{show rig}\{str} : \{show t}}} => \{show u})"
show (Case _ sc alts) = "(Case \{show sc} \{show alts})"
show (Let _ nm t u) = "(Let \{nm} \{show t} \{show u})"
show (LetRec _ nm t u) = "(LetRec \{nm} \{show t} \{show u})"
show (LetRec _ nm ty t u) = "(LetRec \{nm} : \{show ty} \{show t} \{show u})"
show (Erased _) = "ERASED"
public export
@@ -244,7 +244,7 @@ pprint names tm = go 0 names tm
go p names (Case _ sc alts) = parens 0 p $ text "case" <+> go 0 names sc <+> text "of" ++ (nest 2 (line ++ stack (map (goAlt 0 names) alts)))
go p names (Lit _ lit) = text (show lit)
go p names (Let _ nm t u) = parens 0 p $ text "let" <+> text nm <+> ":=" <+> go 0 names t <+> "in" </> (nest 2 $ go 0 (nm :: names) u)
go p names (LetRec _ nm t u) = parens 0 p $ text "letrec" <+> text nm <+> ":=" <+> go 0 names t <+> "in" </> (nest 2 $ go 0 (nm :: names) u)
go p names (LetRec _ nm ty t u) = parens 0 p $ text "letrec" <+> text nm <+> ":" <+> go 0 names ty <+> ":=" <+> go 0 names t <+> "in" </> (nest 2 $ go 0 (nm :: names) u)
go p names (Erased _) = "ERASED"
data Val : Type
@@ -277,7 +277,7 @@ data Val : Type where
VLam : FC -> Name -> Icit -> Quant -> Closure -> Val
VPi : FC -> Name -> Icit -> Quant -> (a : Lazy Val) -> (b : Closure) -> Val
VLet : FC -> Name -> Val -> Val -> Val
VLetRec : FC -> Name -> Val -> Val -> Val
VLetRec : FC -> Name -> Val -> Val -> Val -> Val
VU : FC -> Val
VErased : FC -> Val
VLit : FC -> Literal -> Val
@@ -294,7 +294,7 @@ getValFC (VU fc) = fc
getValFC (VErased fc) = fc
getValFC (VLit fc _) = fc
getValFC (VLet fc _ _ _) = fc
getValFC (VLetRec fc _ _ _) = fc
getValFC (VLetRec fc _ _ _ _) = fc
public export
@@ -316,7 +316,7 @@ Show Val where
show (VU _) = "U"
show (VLit _ lit) = show lit
show (VLet _ nm a b) = "(%let \{show nm} = \{show a} in \{show b}"
show (VLetRec _ nm a b) = "(%letrec \{show nm} = \{show a} in \{show b}"
show (VLetRec _ nm ty a b) = "(%letrec \{show nm} : \{show ty} = \{show a} in \{show b}"
show (VErased _) = "ERASED"
public export