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

Get AOC day1 working

Browse Source 
- Fixes to codegen for literal cases.
- Fix parsing of string literals
- Work around stack overflow in Prettier
This commit is contained in:
Steve Dunham
2024-10-22 20:30:20 -07:00
parent 9148852eb5
commit c7593e831e
13 changed files with 1298 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

65
src/Lib/Compile.idr
View File

@@ -48,8 +48,16 @@ Cont e = JSExp -> JSStmt e
||| JSEnv contains `Var` for binders or `Dot` for destructured data. It
||| used to translate binders
JSEnv : Type
JSEnv = List JSExp
record JSEnv where
constructor MkEnv
env : List JSExp
depth : Nat
push : JSEnv -> JSExp -> JSEnv
push env exp = { env $= (exp ::) } env
empty : JSEnv
empty = MkEnv [] Z
litToJS : Literal -> JSExp
litToJS (LString str) = LitString str
@@ -57,23 +65,24 @@ litToJS (LChar c) = LitString $ cast c
litToJS (LInt i) = LitInt i
-- Stuff nm.h1, nm.h2, ... into environment
mkEnv : String -> Nat -> List JSExp -> List String -> List JSExp
-- TODO consider JSExp instead of nm, so we can have $foo.h1 instead of assigning a sc.
mkEnv : String -> Nat -> JSEnv -> List String -> JSEnv
mkEnv nm k env [] = env
mkEnv nm k env (x :: xs) = mkEnv nm (S k) (Dot (Var nm) "h\{show k}" :: env) xs
mkEnv nm k env (x :: xs) = mkEnv nm (S k) (push env (Dot (Var nm) "h\{show k}")) xs
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 nm then nm else go nm 1
fresh nm env = if free env.env nm then nm else go nm 1
where
free : JSEnv -> String -> Bool
free : List JSExp -> String -> Bool
free [] nm = True
free (Var n :: xs) nm = if n == nm then False else free xs nm
free (_ :: xs) nm = free xs nm
go : String -> Nat -> String
go nm k = let nm' = "\{nm}\{show k}" in if free env nm' then nm' else go nm (S k)
go nm k = let nm' = "\{nm}\{show k}" in if free env.env nm' then nm' else go nm (S k)
-- This is inspired by A-normalization, look into the continuation monad
-- There is an index on JSStmt, adopted from Stefan Hoeck's code.
@@ -81,30 +90,28 @@ fresh nm env = if free env nm then nm else go nm 1
-- Here we turn a Term into a statement (which may be a sequence of statements), there
-- is a continuation, which turns the final JSExpr into a JSStmt, and the function returns
-- a JSStmt, wrapping recursive calls in JSnoc if necessary.
termToJS : List JSExp -> CExp -> Cont e -> JSStmt e
termToJS env (CBnd k) f = case getAt k env of
termToJS : JSEnv -> CExp -> Cont e -> JSStmt e
termToJS env (CBnd k) f = case getAt k env.env of
(Just e) => f e
Nothing => ?bad_bounds
termToJS env (CLam nm t) f =
let nm' = fresh nm env -- "\{nm}$\{show $ length env}"
env' = (Var nm' :: env)
env' = push env (Var nm')
in f $ JLam [nm'] (termToJS env' t JReturn)
termToJS env (CFun nms t) f =
let nms' = map (\nm => fresh nm env) nms
env' = foldl (\ e, nm => Var nm :: e) env nms'
env' = foldl (\ e, nm => push e (Var nm)) env nms'
in f $ JLam nms' (termToJS env' t JReturn)
termToJS env (CRef nm) f = f $ Var nm
termToJS env (CMeta k) f = f $ LitString "META \{show k}"
termToJS env (CLit (LString str)) f = f (LitString str)
termToJS env (CLit (LChar c)) f = f (LitString $ cast c)
termToJS env (CLit (LInt i)) f = f (LitInt i)
termToJS env (CLit lit) f = f (litToJS lit)
-- if it's a var, just use the original
termToJS env (CLet nm (CBnd k) u) f = case getAt k env of
Just e => termToJS (e :: env) u f
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
env' = (Var 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)
@@ -124,20 +131,24 @@ termToJS env (CCase t alts) f =
termToJS env t $ \case
(Var nm) => maybeCaseStmt env nm alts
t' =>
let nm = fresh "sc" env in
JSnoc (JConst nm t') (maybeCaseStmt (Var nm :: env) nm alts)
t' => do
-- TODO refactor nm to be a JSExp with Var{} or Dot{}
let nm = "sc$\{show env.depth}"
let env' = { depth $= S } env
JSnoc (JConst nm t') (maybeCaseStmt env' nm alts)
where
termToJSAlt : List JSExp -> String -> CAlt -> JAlt
termToJSAlt : JSEnv -> String -> CAlt -> JAlt
termToJSAlt env nm (CConAlt name args u) = JConAlt name (termToJS (mkEnv nm 0 env args) u f)
-- intentionally reusing scrutinee name here
termToJSAlt env nm (CDefAlt u) = JDefAlt (termToJS (Var nm :: env) u f)
termToJSAlt env nm (CLitAlt lit u) = JLitAlt (litToJS lit) (termToJS (Var nm :: env) u f)
termToJSAlt env nm (CDefAlt u) = JDefAlt (termToJS (env) u f)
termToJSAlt env nm (CLitAlt lit u) = JLitAlt (litToJS lit) (termToJS env u f)
maybeCaseStmt : List JSExp -> String -> List CAlt -> JSStmt e
maybeCaseStmt : JSEnv -> String -> List CAlt -> JSStmt e
-- If there is a single alt, assume it matched
maybeCaseStmt env nm [(CConAlt _ args u)] = (termToJS (mkEnv nm 0 env args) u f)
maybeCaseStmt env nm alts@(CLitAlt _ _ :: _) =
(JCase (Var nm) (map (termToJSAlt env nm) alts))
maybeCaseStmt env nm alts =
(JCase (Dot (Var nm) "tag") (map (termToJSAlt env nm) alts))
@@ -233,7 +244,7 @@ entryToDoc (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..
let body@(JPlain {}) = termToJS [] ct JPlain
let body@(JPlain {}) = termToJS empty ct JPlain
| js => error (getFC tm) "Not a plain expression: \{render 80 $ stmtToDoc js}"
pure (text "const" <+> jsIdent name <+> text "=" <+/> stmtToDoc body)
entryToDoc (MkEntry name type Axiom) = pure ""
@@ -243,7 +254,7 @@ entryToDoc (MkEntry name type PrimTCon) = pure $ dcon name (piArity type)
entryToDoc (MkEntry name _ (PrimFn src)) = pure $ text "const" <+> jsIdent name <+> "=" <+> text src
export
compile : M Doc
compile : M (List Doc)
compile = do
top <- get
pure $ stack $ !(traverse entryToDoc top.defs)
traverse entryToDoc top.defs

2
src/Lib/Elab.idr
View File

@@ -680,7 +680,7 @@ buildLitCase ctx prob fc scnm scty lit = do
buildLitCases : Context -> Problem -> FC -> String -> Val -> M (List CaseAlt)
buildLitCases ctx prob fc scnm scty = do
let lits = getLits scnm prob.clauses
let lits = nub $ getLits scnm prob.clauses
alts <- traverse (buildLitCase ctx prob fc scnm scty) lits
-- TODO build default case
-- run getLits

3
src/Lib/Tokenizer.idr
View File

@@ -44,6 +44,7 @@ unquote str = case unpack str of
go : List Char -> List Char
go [] = []
go ['"'] = []
go ('\\' :: ('n' :: xs)) = '\n' :: go xs
go ('\\' :: (x :: xs)) = x :: go xs
go (x :: xs) = x :: go xs
@@ -55,7 +56,7 @@ rawTokens
<|> match (is '#' <+> many alpha) (Tok Pragma)
<|> match charLit (Tok Character)
<|> match (exact "_" <+> (some opChar <|> exact ",") <+> exact "_") (Tok MixFix)
<|> match (quo <+> manyUntil quo ((esc any <+> any) <|> any) <+> opt quo) (Tok StringKind . unquote)
<|> match (quo <+> manyUntil quo (esc any <|> any) <+> quo) (Tok StringKind . unquote)
<|> match (lineComment (exact "--")) (Tok Space)
<|> match (blockComment (exact "/-") (exact "-/")) (Tok Space)
<|> match (exact ",") (Tok Oper)

4
src/Lib/Types.idr
View File

@@ -73,7 +73,6 @@ Show Literal where
public export
data CaseAlt : Type where
CaseDefault : Tm -> CaseAlt
-- I've also seen a list of stuff that gets replaced
CaseCons : (name : String) -> (args : List String) -> Tm -> CaseAlt
CaseLit : Literal -> Tm -> CaseAlt
@@ -98,7 +97,6 @@ data Tm : Type where
App : FC -> Tm -> Tm -> Tm
U : FC -> Tm
Pi : FC -> Name -> Icit -> Tm -> Tm -> Tm
-- REVIEW - do we want to just push it up like idris?
Case : FC -> Tm -> List CaseAlt -> Tm
-- need type?
Let : FC -> Name -> Tm -> Tm -> Tm
@@ -173,7 +171,7 @@ pprint names tm = render 80 $ go names tm
goAlt : List String -> CaseAlt -> Doc
goAlt names (CaseDefault t) = "_" <+> "=>" <+> go ("_" :: names) t
goAlt names (CaseCons name args t) = text name <+> spread (map text args) <+> "=>" <+/> go (args ++ names) t
goAlt names (CaseCons name args t) = text name <+> spread (map text args) <+> "=>" <+/> go (reverse args ++ names) t
goAlt names (CaseLit lit t) = text (show lit) <+> "=>" <+/> go names t
go names (Bnd _ k) = case getAt k names of

10
src/Main.idr
View File

@@ -38,15 +38,13 @@ dumpContext top = do
go [] = pure ()
go (x :: xs) = putStrLn " \{show x}" >> go xs
dumpSource : M ()
dumpSource = do
doc <- compile
putStrLn $ render 90 doc
writeSource : String -> M ()
writeSource fn = do
doc <- compile
let src = "#!/usr/bin/env node\n" ++ render 90 doc ++ "\nmain();"
docs <- compile
let src = unlines $ ["#!/usr/bin/env node"]
++ map (render 90) docs
++ [ "main();" ]
Right _ <- writeFile fn src
| Left err => fail (show err)
Right _ <- chmodRaw fn 493 | Left err => fail (show err)