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

add jump to def and type on hover for top level

Browse Source
This commit is contained in:
Steve Dunham
2024-12-07 12:23:47 -08:00
parent 45390066ae
commit 421f5ea208
14 changed files with 378 additions and 174 deletions
Download Patch File Download Diff File Expand all files Collapse all files

68
src/Lib/Common.idr
View File

@@ -1,8 +1,72 @@
module Lib.Common
import Data.String
import Data.Nat
import Data.Maybe
import public Data.SortedMap
hexChars : List Char
hexChars = unpack "0123456789ABCDEF"
-- export
hexDigit : Nat -> Char
hexDigit v = fromMaybe ' ' (getAt (mod v 16) hexChars)
export
toHex : Nat -> List Char
toHex 0 = []
toHex v = snoc (toHex (div v 16)) (hexDigit v)
export
quoteString : String -> String
quoteString str = pack $ encode (unpack str) [< '"']
where
encode : List Char -> SnocList Char -> List Char
encode [] acc = acc <>> ['"']
encode ('"' :: cs) acc = encode cs (acc :< '\\' :< '"')
encode ('\n' :: cs) acc = encode cs (acc :< '\\' :< 'n')
encode ('\\' :: cs) acc = encode cs (acc :< '\\' :< '\\')
encode (c :: cs) acc =
let v : Nat = cast c in
if v < 32 then encode cs (acc :< '\\' :< 'u' :< hexDigit (div v 4096) :< hexDigit (div v 256) :< hexDigit (div v 16) :< hexDigit v )
else encode cs (acc :< c)
-- else if v < 128 then encode cs (acc :< c)
-- if v < 32 then encode cs (acc :< '\\' :< 'x' :< hexDigit (div v 16) :< hexDigit v )
-- else if v < 128 then encode cs (acc :< c)
-- -- TODO unicode
-- else if v < 256 then encode cs (acc :< '\\' :< 'x' :< hexDigit (div v 16) :< hexDigit v )
-- else encode cs (acc :< '\\' :< 'u' :< hexDigit (div v 4096) :< hexDigit (div v 256) :< hexDigit (div v 16) :< hexDigit v )
public export
data Json : Type where
JsonObj : List (String, Json) -> Json
JsonStr : String -> Json
JsonBool : Bool -> Json
JsonInt : Int -> Json
JsonArray : List Json -> Json
export
renderJson : Json -> String
renderJson (JsonObj xs) = "{" ++ joinBy "," (map renderPair xs) ++ "}"
where
renderPair : (String,Json) -> String
renderPair (k,v) = quoteString k ++ ":" ++ renderJson v
renderJson (JsonStr str) = quoteString str
renderJson (JsonBool x) = ifThenElse x "true" "false"
renderJson (JsonInt i) = cast i
renderJson (JsonArray xs) = "[" ++ joinBy "," (map renderJson xs) ++ "]"
public export
interface ToJSON a where
toJson : a -> Json
export
ToJSON String where
toJson = JsonStr
export
ToJSON Int where
toJson = JsonInt
public export
record FC where
@@ -10,6 +74,10 @@ record FC where
file : String
start : (Int,Int)
export
ToJSON FC where
toJson (MkFC file (line,col)) = JsonObj [ ("file", toJson file), ("line", toJson line), ("col", toJson col)]
export
(.line) : FC -> Int
fc.line = fst fc.start

49
src/Lib/Compile.idr
View File

@@ -171,33 +171,6 @@ termToJS env (CCase t alts) f =
maybeCaseStmt env nm alts =
(JCase (Dot (Var nm) "tag") (map (termToJSAlt env nm) alts))
chars : List Char
chars = unpack "0123456789ABCDEF"
hexDigit : Nat -> Char
hexDigit v = fromMaybe ' ' (getAt (mod v 16) chars)
toHex : Nat -> List Char
toHex 0 = []
toHex v = snoc (toHex (div v 16)) (hexDigit v)
-- FIXME escaping is wrong, e.g. \215 instead of \xd7
jsString : String -> Doc
jsString str = text $ pack $ encode (unpack str) [< '"']
where
encode : List Char -> SnocList Char -> List Char
encode [] acc = acc <>> ['"']
encode ('"' :: cs) acc = encode cs (acc :< '\\' :< '"')
encode ('\n' :: cs) acc = encode cs (acc :< '\\' :< 'n')
encode ('\\' :: cs) acc = encode cs (acc :< '\\' :< '\\')
encode (c :: cs) acc =
let v : Nat = cast c in
if v < 32 then encode cs (acc :< '\\' :< 'x' :< hexDigit (div v 16) :< hexDigit v )
else if v < 128 then encode cs (acc :< c)
-- TODO unicode
else if v < 256 then encode cs (acc :< '\\' :< 'x' :< hexDigit (div v 16) :< hexDigit v )
else encode cs (acc :< '\\' :< 'u' :< hexDigit (div v 4096) :< hexDigit (div v 256) :< hexDigit (div v 16) :< hexDigit v )
keywords : List String
keywords = [
"var", "true", "false", "let", "case", "switch", "if", "then", "else", "String",
@@ -232,7 +205,7 @@ expToDoc (LitObject xs) = text "{" <+> folddoc (\ a, e => a ++ ", " <+/> e) (map
-- TODO quote if needed
entry (nm, exp) = jsIdent nm ++ ":" <+> expToDoc exp
expToDoc (LitString str) = jsString str
expToDoc (LitString str) = text $ quoteString str
expToDoc (LitInt i) = text $ show i
-- TODO add precedence
expToDoc (Apply x@(JLam{}) xs) = text "(" ++ expToDoc x ++ ")" ++ "(" ++ nest 2 (commaSep (map expToDoc xs)) ++ ")"
@@ -251,7 +224,7 @@ caseBody {e} stmt@(JCase{}) = nest 2 (line ++ stmtToDoc stmt </> text "break;")
caseBody stmt = line ++ "{" ++ nest 2 (line ++ stmtToDoc stmt </> text "break;") </> "}"
altToDoc : JAlt -> Doc
altToDoc (JConAlt nm stmt) = text "case" <+> jsString nm ++ ":" ++ caseBody stmt
altToDoc (JConAlt nm stmt) = text "case" <+> text (quoteString nm) ++ ":" ++ caseBody stmt
altToDoc (JDefAlt stmt) = text "default" ++ ":" ++ caseBody stmt
altToDoc (JLitAlt a stmt) = text "case" <+> expToDoc a ++ ":" ++ caseBody stmt
@@ -262,7 +235,7 @@ stmtToDoc (JLet nm body) = "let" <+> jsIdent nm ++ ";" </> stmtToDoc body
stmtToDoc (JAssign nm expr) = jsIdent nm <+> "=" <+> expToDoc expr ++ ";"
stmtToDoc (JConst nm x) = text "const" <+> jsIdent nm <+> nest 2 ("=" <+/> expToDoc x ++ ";")
stmtToDoc (JReturn x) = text "return" <+> expToDoc x ++ ";"
stmtToDoc (JError str) = text "throw new Error(" ++ jsString str ++ ");"
stmtToDoc (JError str) = text "throw new Error(" ++ text (quoteString str) ++ ");"
stmtToDoc (JCase sc alts) =
text "switch (" ++ expToDoc sc ++ ")" <+> bracket "{" (stack $ map altToDoc alts) "}"
@@ -283,16 +256,16 @@ maybeWrap (JReturn exp) = exp
maybeWrap stmt = Apply (JLam [] stmt) []
entryToDoc : TopEntry -> M Doc
entryToDoc (MkEntry name ty (Fn tm)) = do
entryToDoc (MkEntry _ name ty (Fn tm)) = do
debug "compileFun \{pprint [] tm}"
ct <- compileFun tm
let exp = maybeWrap $ termToJS empty ct JReturn
pure $ text "const" <+> jsIdent name <+> text "=" <+/> expToDoc exp ++ ";"
entryToDoc (MkEntry name type Axiom) = pure ""
entryToDoc (MkEntry name type (TCon strs)) = pure $ dcon name (piArity type)
entryToDoc (MkEntry name type (DCon arity str)) = pure $ dcon name arity
entryToDoc (MkEntry name type PrimTCon) = pure $ dcon name (piArity type)
entryToDoc (MkEntry name _ (PrimFn src _)) = pure $ text "const" <+> jsIdent name <+> "=" <+> text src
entryToDoc (MkEntry _ name type Axiom) = pure ""
entryToDoc (MkEntry _ name type (TCon strs)) = pure $ dcon name (piArity type)
entryToDoc (MkEntry _ name type (DCon arity str)) = pure $ dcon name arity
entryToDoc (MkEntry _ name type PrimTCon) = pure $ dcon name (piArity type)
entryToDoc (MkEntry _ name _ (PrimFn src _)) = pure $ text "const" <+> jsIdent name <+> "=" <+> text src
||| This version (call `reverse . snd <$> process "main" ([],[])`) will do dead
||| code elimination, but the Prelude js primitives are reaching for
@@ -303,10 +276,10 @@ process (done,docs) nm = do
top <- get
case TopContext.lookup nm top of
Nothing => error emptyFC "\{nm} not in scope"
Just entry@(MkEntry name ty (PrimFn src uses)) => do
Just entry@(MkEntry _ name ty (PrimFn src uses)) => do
(done,docs) <- foldlM process (nm :: done, docs) uses
pure (done, !(entryToDoc entry) :: docs)
Just (MkEntry name ty (Fn tm)) => do
Just (MkEntry _ name ty (Fn tm)) => do
debug "compileFun \{pprint [] tm}"
ct <- compileFun tm
-- If ct has zero arity and is a compount expression, this fails..

16
src/Lib/CompileExp.idr
View File

@@ -62,13 +62,13 @@ arityForName : FC -> Name -> M Nat
arityForName fc nm = case lookup nm !get of
-- let the magic hole through for now (will generate bad JS)
Nothing => error fc "Name \{show nm} not in scope"
(Just (MkEntry name type Axiom)) => pure 0
(Just (MkEntry name type (TCon strs))) => pure $ piArity type
(Just (MkEntry name type (DCon k str))) => pure k
(Just (MkEntry name type (Fn t))) => pure $ lamArity t
(Just (MkEntry name type (PrimTCon))) => pure $ piArity type
(Just (MkEntry _ name type Axiom)) => pure 0
(Just (MkEntry _ name type (TCon strs))) => pure $ piArity type
(Just (MkEntry _ name type (DCon k str))) => pure k
(Just (MkEntry _ name type (Fn t))) => pure $ lamArity t
(Just (MkEntry _ name type (PrimTCon))) => pure $ piArity type
-- Assuming a primitive can't return a function
(Just (MkEntry name type (PrimFn t uses))) => pure $ piArity type
(Just (MkEntry _ name type (PrimFn t uses))) => pure $ piArity type
export
compileTerm : Tm -> M CExp
@@ -109,7 +109,7 @@ compileTerm (Bnd _ k) = pure $ CBnd k
-- need to eta expand to arity
compileTerm t@(Ref fc nm _) = do
top <- get
let Just (MkEntry _ type _) = lookup nm top
let Just (MkEntry _ _ type _) = lookup nm top
| Nothing => error fc "Undefined name \{nm}"
apply (CRef nm) [] [<] !(arityForName fc nm) type
@@ -123,7 +123,7 @@ compileTerm tm@(App _ _ _) with (funArgs tm)
args' <- traverse compileTerm args
arity <- arityForName fc nm
top <- get
let Just (MkEntry _ type _) = lookup nm top
let Just (MkEntry _ _ type _) = lookup nm top
| Nothing => error fc "Undefined name \{nm}"
apply (CRef nm) args' [<] arity type
_ | (t, args) = do

31
src/Lib/Elab.idr
View File

@@ -331,13 +331,13 @@ unify env mode t u = do
unify' t u@(VRef fc' k' def sp') = do
debug "expand \{show t} =?= %ref \{k'}"
case lookup k' !(get) of
Just (MkEntry name ty (Fn tm)) => unify env mode t !(vappSpine !(eval [] CBN tm) sp')
Just (MkEntry _ name ty (Fn tm)) => unify env mode t !(vappSpine !(eval [] CBN tm) sp')
_ => error fc' "unify failed \{show t} =?= \{show u} [no Fn]\n env is \{show env}"
unify' t@(VRef fc k def sp) u = do
debug "expand %ref \{k} \{show sp} =?= \{show u}"
case lookup k !(get) of
Just (MkEntry name ty (Fn tm)) => unify env mode !(vappSpine !(eval [] CBN tm) sp) u
Just (MkEntry _ name ty (Fn tm)) => unify env mode !(vappSpine !(eval [] CBN tm) sp) u
_ => error fc "unify failed \{show t} [no Fn] =?= \{show u}\n env is \{show env}"
-- REVIEW I'd like to quote this back, but we have l that aren't in the environment.
@@ -397,7 +397,7 @@ insert ctx tm ty = do
primType : FC -> String -> M Val
primType fc nm = case lookup nm !(get) of
Just (MkEntry name ty PrimTCon) => pure $ VRef fc name PrimTCon [<]
Just (MkEntry _ name ty PrimTCon) => pure $ VRef fc name PrimTCon [<]
_ => error fc "Primitive type \{show nm} not in scope"
export
@@ -470,12 +470,12 @@ getConstructors ctx scfc (VRef fc nm _ _) = do
where
lookupTCon : String -> M (List String)
lookupTCon str = case lookup nm !get of
(Just (MkEntry name type (TCon names))) => pure names
(Just (MkEntry _ name type (TCon names))) => pure names
_ => error scfc "Not a type constructor \{nm}"
lookupDCon : String -> M (String, Nat, Tm)
lookupDCon nm = do
case lookup nm !get of
(Just (MkEntry name type (DCon k str))) => pure (name, k, type)
(Just (MkEntry _ name type (DCon k str))) => pure (name, k, type)
Just _ => error fc "Internal Error: \{nm} is not a DCon"
Nothing => error fc "Internal Error: DCon \{nm} not found"
getConstructors ctx scfc tm = error scfc "Can't split - not VRef: \{!(pprint ctx tm)}"
@@ -676,7 +676,7 @@ mkPat : TopContext -> (Raw, Icit) -> M Pattern
mkPat top (tm, icit) = do
case splitArgs tm [] of
((RVar fc nm), b) => case lookup nm top of
(Just (MkEntry name type (DCon k str))) =>
(Just (MkEntry _ name type (DCon k str))) =>
-- TODO check arity, also figure out why we need reverse
pure $ PatCon fc icit nm !(traverse (mkPat top) b)
-- This fires when a global is shadowed by a pattern var
@@ -994,21 +994,10 @@ check ctx tm ty = case (tm, !(forceType ctx.env ty)) of
pure $ Lam (getFC tm) nm' Auto rig sc
(tm,ty) => do
-- We need to insert if tm is not an Implicit Lam
-- assuming all of the implicit ty have been handled above
(tm', ty') <- infer ctx tm
(tm', ty') <- insert ctx tm' ty'
let names = toList $ map fst ctx.types
(tm', ty') <- case !(infer ctx tm) of
-- Kovacs doesn't insert on tm = Implicit Lam, we don't have Plicity in Lam
-- so I'll check the inferred type for an implicit pi
-- This seems wrong, the ty' is what insert runs on, so we're just short circuiting here
-- REVIEW - I think we need icit on Lam, check that they match and drop the two "edge" above?
-- (tm'@(Lam{}), ty'@(VPi _ _ Implicit rig _ _)) => do debug "CheckMe 1"; pure (tm', ty')
-- (tm'@(Lam{}), ty'@(VPi _ _ Auto rig _ _)) => do debug "CheckMe 2"; pure (tm', ty')
(tm', ty') => do
debug "RUN INSERT ON \{pprint names tm'} at \{show ty'}"
insert ctx tm' ty'
debug "INFER \{show tm} to (\{pprint names tm'} : \{show ty'}) expect \{show ty}"
unifyCatch (getFC tm) ctx ty' ty
pure tm'
@@ -1017,7 +1006,7 @@ infer ctx (RVar fc nm) = go 0 ctx.types
where
go : Nat -> Vect n (String, Val) -> M (Tm, Val)
go i [] = case lookup nm !(get) of
Just (MkEntry name ty def) => do
Just (MkEntry _ name ty def) => do
debug "lookup \{name} as \{show def}"
pure (Ref fc nm def, !(eval [] CBN ty))
Nothing => error fc "\{show nm} not in scope"

7
src/Lib/Erasure.idr
View File

@@ -13,7 +13,7 @@ getType (Ref fc nm x) = do
top <- get
case lookup nm top of
Nothing => pure Nothing
(Just (MkEntry name type def)) => pure $ Just type
(Just (MkEntry _ name type def)) => pure $ Just type
getType tm = pure Nothing
export
@@ -37,7 +37,7 @@ doAlt : EEnv -> CaseAlt -> M CaseAlt
doAlt env (CaseDefault t) = CaseDefault <$> erase env t []
doAlt env (CaseCons name args t) = do
top <- get
let Just (MkEntry str type def) = lookup name top
let Just (MkEntry _ str type def) = lookup name top
| _ => error emptyFC "\{name} dcon missing from context"
let env' = piEnv env type args
CaseCons name args <$> erase env' t []
@@ -58,8 +58,7 @@ erase env t sp = case t of
top <- get
case lookup nm top of
Nothing => eraseSpine env t sp Nothing
(Just (MkEntry name type def)) => eraseSpine env t sp (Just type)
(Lam fc nm icit rig u) => Lam fc nm icit rig <$> erase ((nm, rig, Nothing) :: env) u []
(Just (MkEntry _ name type def)) => eraseSpine env t sp (Just type)
(Lam fc nm icit rig u) => Lam fc nm icit rig <$> erase ((nm, rig, Nothing) :: env) u []
-- If we get here, we're looking at a runtime pi type
(Pi fc nm icit rig u v) => do

4
src/Lib/Eval.idr
View File

@@ -73,7 +73,7 @@ export
tryEval : Env -> Val -> M (Maybe Val)
tryEval env (VRef fc k _ sp) =
case lookup k !(get) of
Just (MkEntry name ty (Fn tm)) =>
Just (MkEntry _ name ty (Fn tm)) =>
catchError {e=Error} (
do
debug "app \{name} to \{show sp}"
@@ -105,7 +105,7 @@ evalCase env mode sc@(VRef _ nm _ sp) (cc@(CaseCons name nms t) :: xs) =
debug "ECase \{nm} \{show sp} \{show nms} \{showTm t}"
go env (sp <>> []) nms
else case lookup nm !(get) of
(Just (MkEntry str type (DCon k str1))) => evalCase env mode sc xs
(Just (MkEntry _ str type (DCon k str1))) => evalCase env mode sc xs
-- bail for a stuck function
_ => pure Nothing
where

14
src/Lib/ProcessDecl.idr
View File

@@ -29,7 +29,7 @@ isCandidate _ _ = False
-- TODO consider ctx
findMatches : Context -> Val -> List TopEntry -> M (List (Tm, MetaContext))
findMatches ctx ty [] = pure []
findMatches ctx ty ((MkEntry name type def) :: xs) = do
findMatches ctx ty ((MkEntry _ name type def) :: xs) = do
let True = isCandidate ty type | False => findMatches ctx ty xs
top <- get
-- let ctx = mkCtx (getFC ty)
@@ -181,8 +181,8 @@ processDecl (TypeSig fc names tm) = do
| _ => error fc "\{show nm} is already defined"
pure ()
ty <- check (mkCtx fc) tm (VU fc)
ty <- zonk top 0 [] ty
putStrLn "TypeSig \{unwords names} : \{pprint [] ty}"
debug "got \{pprint [] ty}"
for_ names $ \nm => setDef nm fc ty Axiom
-- Zoo4eg has metas in TypeSig, need to decide if I want to support leaving them unsolved here
-- logMetas mstart
@@ -211,7 +211,7 @@ processDecl (Def fc nm clauses) = do
let mstart = length mc.metas
let Just entry = lookup nm top
| Nothing => throwError $ E fc "No declaration for \{nm}"
let (MkEntry name ty Axiom) := entry
let (MkEntry fc name ty Axiom) := entry
| _ => throwError $ E fc "\{nm} already defined"
putStrLn "check \{nm} at \{pprint [] ty}"
@@ -324,11 +324,11 @@ processDecl (Instance instfc ty decls) = do
let (Ref _ tconName _, args) := funArgs codomain
| (tm, _) => error tyFC "\{pprint [] codomain} doesn't appear to be a TCon application"
let (Just (MkEntry name type (TCon cons))) = lookup tconName top
let (Just (MkEntry _ name type (TCon cons))) = lookup tconName top
| _ => error tyFC "\{tconName} is not a type constructor"
let [con] = cons
| _ => error tyFC "\{tconName} has multiple constructors \{show cons}"
let (Just (MkEntry _ dcty (DCon _ _))) = lookup con top
let (Just (MkEntry _ _ dcty (DCon _ _))) = lookup con top
| _ => error tyFC "can't find constructor \{show con}"
vdcty@(VPi _ nm icit rig a b) <- eval [] CBN dcty
| x => error (getFC x) "dcty not Pi"
@@ -402,9 +402,9 @@ processDecl (Data fc nm ty cons) = do
let mstart = length mc.metas
tyty <- check (mkCtx fc) ty (VU fc)
case lookup nm top of
Just (MkEntry name type Axiom) => do
Just (MkEntry _ name type Axiom) => do
unifyCatch fc (mkCtx fc) !(eval [] CBN tyty) !(eval [] CBN type)
Just (MkEntry name type _) => error fc "\{show nm} already declared"
Just (MkEntry _ name type _) => error fc "\{show nm} already declared"
Nothing => setDef nm fc tyty Axiom
cnames <- for cons $ \x => case x of
(TypeSig fc names tm) => do

9
src/Lib/TopContext.idr
View File

@@ -44,8 +44,8 @@ setDef name fc ty def = do
put $ { defs := defs } top
where
go : List TopEntry -> M (List TopEntry)
go [] = pure $ [MkEntry name ty def]
go (x@(MkEntry nm ty' def') :: defs) = if nm == name
go [] = pure $ [MkEntry fc name ty def]
go (x@(MkEntry _ nm ty' def') :: defs) = if nm == name
then error fc "\{name} is already defined"
else (x ::) <$> go defs
@@ -58,8 +58,9 @@ updateDef name fc ty def = do
where
go : List TopEntry -> M (List TopEntry)
go [] = error fc "\{name} not declared"
go (x@(MkEntry nm ty' def') :: defs) = if nm == name
then pure $ MkEntry name ty def :: defs
go (x@(MkEntry fc' nm ty' def') :: defs) = if nm == name
-- keep original fc, so it points to the TypeSig
then pure $ MkEntry fc' name ty def :: defs
else (x ::) <$> go defs

3
src/Lib/Types.idr
View File

@@ -404,6 +404,7 @@ Show Def where
public export
record TopEntry where
constructor MkEntry
fc : FC
name : String
type : Tm
def : Def
@@ -413,7 +414,7 @@ record TopEntry where
export
covering
Show TopEntry where
show (MkEntry name type def) = "\{name} : \{show type} := \{show def}"
show (MkEntry fc name type def) = "\{name} : \{show type} := \{show def}"
||| Top level context.
||| Most of the reason this is separate is to have a different type