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

Newt in Newt compiles (but does not run)

Browse Source
This commit is contained in:
Steve Dunham
2025-01-04 09:26:33 -08:00
parent 46434cc555
commit 6b1eef86a7
21 changed files with 2970 additions and 91 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
src/Lib/Compile.idr
View File

@@ -74,8 +74,8 @@ mkEnv nm k env (x :: xs) = mkEnv nm (S k) (push env (Dot (Var nm) "h\{show k}"))
envNames : Env -> List String
||| given a name, find a similar one that doesn't shadow in Env
fresh : String -> JSEnv -> String
fresh nm env = if free env.env nm then nm else go nm 1
freshName : String -> JSEnv -> String
freshName nm env = if free env.env nm then nm else go nm 1
where
free : List JSExp -> String -> Bool
free [] nm = True
@@ -85,9 +85,9 @@ fresh nm env = if free env.env nm then nm else go nm 1
go : String -> Nat -> String
go nm k = let nm' = "\{nm}\{show k}" in if free env.env nm' then nm' else go nm (S k)
fresh' : String -> JSEnv -> (String, JSEnv)
fresh' nm env =
let nm' = fresh nm env -- "\{nm}$\{show $ length env}"
freshName' : String -> JSEnv -> (String, JSEnv)
freshName' nm env =
let nm' = freshName nm env -- "\{nm}$\{show $ length env}"
env' = push env (Var nm')
in (nm', env')
@@ -97,7 +97,7 @@ freshNames nms env = go nms env [<]
go : List Name -> JSEnv -> SnocList Name -> (List String, JSEnv)
go Nil env acc = (acc <>> Nil, env)
go (n :: ns) env acc =
let (n', env') = fresh' n env
let (n', env') = freshName' n env
in go ns env' (acc :< n')
-- This is inspired by A-normalization, look into the continuation monad
@@ -112,7 +112,7 @@ termToJS env (CBnd k) f = case getAt k env.env of
Nothing => ?bad_bounds
termToJS env CErased f = f JUndefined
termToJS env (CLam nm t) f =
let (nm',env') = fresh' nm env -- "\{nm}$\{show $ length env}"
let (nm',env') = freshName' nm env -- "\{nm}$\{show $ length env}"
in f $ JLam [nm'] (termToJS env' t JReturn)
termToJS env (CFun nms t) f =
let (nms', env') = freshNames nms env
@@ -125,14 +125,14 @@ termToJS env (CLet nm (CBnd k) u) f = case getAt k env.env of
Just e => termToJS (push env e) u f
Nothing => ?bad_bounds2
termToJS env (CLet nm t u) f =
let nm' = fresh nm env
let nm' = freshName nm env
env' = push env (Var nm')
-- If it's a simple term, use const
in case termToJS env t (JAssign nm') of
(JAssign _ exp) => JSnoc (JConst nm' exp) (termToJS env' u f)
t' => JSnoc (JLet nm' t') (termToJS env' u f)
termToJS env (CLetRec nm t u) f =
let nm' = fresh nm env
let nm' = freshName nm env
env' = push env (Var nm')
-- If it's a simple term, use const
in case termToJS env' t (JAssign nm') of
@@ -144,7 +144,7 @@ termToJS env (CApp t args etas) f = termToJS env t (\ t' => (argsToJS t' args [<
etaExpand : JSEnv -> Nat -> SnocList JSExp -> JSExp -> JSExp
etaExpand env Z args tm = Apply tm (args <>> [])
etaExpand env (S etas) args tm =
let nm' = fresh "eta" env
let nm' = freshName "eta" env
env' = push env (Var nm')
in JLam [nm'] $ JReturn $ etaExpand (push env (Var nm')) etas (args :< Var nm') tm
@@ -164,7 +164,7 @@ termToJS env (CCase t alts) f =
t' => do
-- TODO refactor nm to be a JSExp with Var{} or Dot{}
-- FIXME sc$ seemed to shadow something else, lets get this straightened out
-- we need fresh names that are not in env (i.e. do not play in debruijn)
-- we need freshName names that are not in env (i.e. do not play in debruijn)
let nm = "_sc$\{show env.depth}"
let env' = { depth $= S } env
JSnoc (JConst nm t') (maybeCaseStmt env' nm alts)
@@ -184,8 +184,8 @@ termToJS env (CCase t alts) f =
maybeCaseStmt env nm alts =
(JCase (Dot (Var nm) "tag") (map (termToJSAlt env nm) alts))
keywords : List String
keywords = [
jsKeywords : List String
jsKeywords = [
"break", "case", "catch", "continue", "debugger", "default", "delete", "do", "else",
"finally", "for", "function", "if", "in", "instanceof", "new", "return", "switch",
"this", "throw", "try", "typeof", "var", "void", "while", "with",
@@ -199,7 +199,7 @@ keywords = [
||| escape identifiers for js
jsIdent : String -> Doc
jsIdent id = if elem id keywords then text ("$" ++ id) else text $ pack $ fix (unpack id)
jsIdent id = if elem id jsKeywords then text ("$" ++ id) else text $ pack $ fix (unpack id)
where
fix : List Char -> List Char
fix [] = []

81
src/Lib/Elab.idr
View File

@@ -320,45 +320,48 @@ invert lvl sp = go sp []
-- we have to "lift" the renaming when we go under a lambda
-- I think that essentially means our domain ix are one bigger, since we're looking at lvl
-- in the codomain, so maybe we can just keep that value
rename : Nat -> List Nat -> Nat -> Val -> M Tm
rename meta ren lvl v = go ren lvl v
where
go : List Nat -> Nat -> Val -> M Tm
goSpine : List Nat -> Nat -> Tm -> SnocList Val -> M Tm
goSpine ren lvl tm [<] = pure tm
goSpine ren lvl tm (xs :< x) = do
xtm <- go ren lvl x
pure $ App emptyFC !(goSpine ren lvl tm xs) xtm
go ren lvl (VVar fc k sp) = case findIndex (== k) ren of
Nothing => error fc "scope/skolem thinger VVar \{show k} ren \{show ren}"
Just x => goSpine ren lvl (Bnd fc $ cast x) sp
go ren lvl (VRef fc nm def sp) = goSpine ren lvl (Ref fc nm def) sp
go ren lvl (VMeta fc ix sp) = do
-- So sometimes we have an unsolved meta in here which reference vars out of scope.
debug "rename Meta \{show ix} spine \{show sp}"
if ix == meta
-- REVIEW is this the right fc?
then error fc "meta occurs check"
else case !(lookupMeta ix) of
Solved fc _ val => do
debug "rename: \{show ix} is solved"
go ren lvl !(vappSpine val sp)
_ => do
debug "rename: \{show ix} is unsolved"
catchError (goSpine ren lvl (Meta fc ix) sp) (\err => throwError $ Postpone fc ix (errorMsg err))
go ren lvl (VLam fc n icit rig t) = pure (Lam fc n icit rig !(go (lvl :: ren) (S lvl) !(t $$ VVar fc lvl [<])))
go ren lvl (VPi fc n icit rig ty tm) = pure (Pi fc n icit rig !(go ren lvl ty) !(go (lvl :: ren) (S lvl) !(tm $$ VVar emptyFC lvl [<])))
go ren lvl (VU fc) = pure (UU fc)
go ren lvl (VErased fc) = pure (Erased fc)
-- for now, we don't do solutions with case in them.
go ren lvl (VCase fc sc alts) = error fc "Case in solution"
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)
-- 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)
rename : Nat -> List Nat -> Nat -> Val -> M Tm
renameSpine : Nat -> List Nat -> Nat -> Tm -> SnocList Val -> M Tm
renameSpine meta ren lvl tm [<] = pure tm
renameSpine meta ren lvl tm (xs :< x) = do
xtm <- rename meta ren lvl x
pure $ App emptyFC !(renameSpine meta ren lvl tm xs) xtm
rename meta ren lvl (VVar fc k sp) = case findIndex (== k) ren of
Nothing => error fc "scope/skolem thinger VVar \{show k} ren \{show ren}"
Just x => renameSpine meta ren lvl (Bnd fc $ cast x) sp
rename meta ren lvl (VRef fc nm def sp) = renameSpine meta ren lvl (Ref fc nm def) sp
rename meta ren lvl (VMeta fc ix sp) = do
-- So sometimes we have an unsolved meta in here which reference vars out of scope.
debug "rename Meta \{show ix} spine \{show sp}"
if ix == meta
-- REVIEW is this the right fc?
then error fc "meta occurs check"
else case !(lookupMeta ix) of
Solved fc _ val => do
debug "rename: \{show ix} is solved"
rename meta ren lvl !(vappSpine val sp)
_ => do
debug "rename: \{show ix} is unsolved"
catchError (renameSpine meta ren lvl (Meta fc ix) sp) (\err => throwError $ Postpone fc ix (errorMsg err))
rename meta ren lvl (VLam fc n icit rig t) = pure (Lam fc n icit rig !(rename meta (lvl :: ren) (S lvl) !(t $$ VVar fc lvl [<])))
rename meta ren lvl (VPi fc n icit rig ty tm) = pure (Pi fc n icit rig !(rename meta ren lvl ty) !(rename meta (lvl :: ren) (S lvl) !(tm $$ VVar emptyFC lvl [<])))
rename meta ren lvl (VU fc) = pure (UU fc)
rename meta ren lvl (VErased fc) = pure (Erased fc)
-- for now, we don't do solutions with case in them.
rename meta ren lvl (VCase fc sc alts) = error fc "Case in solution"
rename meta ren lvl (VLit fc lit) = pure (Lit fc lit)
rename meta ren lvl (VLet fc name val body) =
pure $ Let fc name !(rename meta ren lvl val) !(rename meta (lvl :: ren) (S lvl) body)
-- these probably shouldn't show up in solutions...
rename meta ren lvl (VLetRec fc name ty val body) =
pure $ LetRec fc name !(rename meta ren lvl ty) !(rename meta (lvl :: ren) (S lvl) val) !(rename meta (lvl :: ren) (S lvl) body)
lams : Nat -> List String -> Tm -> Tm
lams 0 _ tm = tm
@@ -564,7 +567,7 @@ unifyCatch fc ctx ty' ty = do
a <- quote ctx.lvl ty'
b <- quote ctx.lvl ty
let names = toList $ map fst ctx.types
let msg = "unification failure\n failed to unify \{pprint names a}\n with \{pprint names b}"
let msg = "xxunification failure\n failed to unify \{pprint names a}\n with \{pprint names b}"
let msg = msg ++ "\nconstraints \{show cs.constraints}"
throwError (E fc msg)
-- error fc "Unification yields constraints \{show cs.constraints}"

1
src/Lib/Eval.idr
View File

@@ -79,6 +79,7 @@ tryEval env (VRef fc k _ sp) = do
val <- vappSpine vtm sp
case val of
VCase _ _ _ => pure Nothing
VLetRec _ _ _ _ _ => pure Nothing
v => pure $ Just v)
(\ _ => pure Nothing)
_ => pure Nothing

12
src/Lib/ProcessDecl.idr
View File

@@ -83,7 +83,7 @@ getSigs : List Decl -> List (FC, String, Raw)
getSigs [] = []
getSigs ((TypeSig _ [] _) :: xs) = getSigs xs
getSigs ((TypeSig fc (nm :: nms) ty) :: xs) = (fc, nm, ty) :: getSigs xs
getSigs (_:: xs) = getSigs xs
getSigs (_ :: xs) = getSigs xs
teleToPi : Telescope -> Raw -> Raw
teleToPi [] end = end
@@ -272,8 +272,8 @@ processDecl ns (Instance instfc ty decls) = do
conTele <- getFields !(apply vdcty args') env []
-- declare individual functions, collect their defs
defs <- for conTele $ \case
(MkBind fc nm Explicit rig ty) => do
let ty' = foldr (\(MkBind fc nm' icit rig ty'), acc => Pi fc nm' icit rig ty' acc) ty tele
(MkBinder fc nm Explicit rig ty) => do
let ty' = foldr (\(MkBinder fc nm' icit rig ty'), acc => Pi fc nm' icit rig ty' acc) ty tele
let nm' = "\{instname},\{nm}"
-- we're working with a Tm, so we define directly instead of processDecl
let Just (Def fc name xs) = find (\case (Def y name xs) => name == nm; _ => False) decls
@@ -302,7 +302,7 @@ processDecl ns (Instance instfc ty decls) = do
-- We're assuming they don't depend on each other.
getFields : Val -> Env -> List Binder -> M (List Binder)
getFields tm@(VPi fc nm Explicit rig ty sc) env bnds = do
bnd <- MkBind fc nm Explicit rig <$> quote (length env) ty
bnd <- MkBinder fc nm Explicit rig <$> quote (length env) ty
getFields !(sc $$ VVar fc (length env) [<]) env (bnd :: bnds)
getFields tm@(VPi fc nm _ rig ty sc) env bnds = getFields !(sc $$ VVar fc (length env) [<]) env bnds
getFields tm xs bnds = pure $ reverse bnds
@@ -312,7 +312,7 @@ processDecl ns (Instance instfc ty decls) = do
tenv (S k) = (VVar emptyFC k [<] :: tenv k)
mkRHS : String -> List Binder -> Raw -> Raw
mkRHS instName (MkBind fc nm Explicit rig ty :: bs) tm = mkRHS instName bs (RApp fc tm (RVar fc "\{instName},\{nm}") Explicit)
mkRHS instName (MkBinder fc nm Explicit rig ty :: bs) tm = mkRHS instName bs (RApp fc tm (RVar fc "\{instName},\{nm}") Explicit)
mkRHS instName (b :: bs) tm = mkRHS instName bs tm
mkRHS instName [] tm = tm
@@ -364,7 +364,7 @@ processDecl ns (Data fc nm ty cons) = do
-- We know it's in U because it's part of a checked Pi type
let (codomain, tele) = splitTele dty
-- for printing
let tnames = reverse $ map (\(MkBind _ nm _ _ _) => nm) tele
let tnames = reverse $ map (\(MkBinder _ nm _ _ _) => nm) tele
let (Ref _ hn _, args) := funArgs codomain
| (tm, _) => error (getFC tm) "expected \{nm} got \{pprint tnames tm}"
when (hn /= QN ns nm) $

6
src/Lib/Util.idr
View File

@@ -12,17 +12,17 @@ funArgs tm = go tm []
public export
data Binder : Type where
MkBind : FC -> String -> Icit -> Quant -> Tm -> Binder
MkBinder : FC -> String -> Icit -> Quant -> Tm -> Binder
-- I don't have a show for terms without a name list
export
Show Binder where
show (MkBind _ nm icit quant t) = "[\{show quant}\{nm} \{show icit} : ...]"
show (MkBinder _ nm icit quant t) = "[\{show quant}\{nm} \{show icit} : ...]"
export
splitTele : Tm -> (Tm, List Binder)
splitTele = go []
where
go : List Binder -> Tm -> (Tm, List Binder)
go ts (Pi fc nm icit quant t u) = go (MkBind fc nm icit quant t :: ts) u
go ts (Pi fc nm icit quant t u) = go (MkBinder fc nm icit quant t :: ts) u
go ts tm = (tm, reverse ts)