Get AOC day1 working

- Fixes to codegen for literal cases.
- Fix parsing of string literals
- Work around stack overflow in Prettier

src/Lib/Compile.idr

@@ -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

src/Lib/Elab.idr

@@ -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

src/Lib/Tokenizer.idr

@@ -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)

src/Lib/Types.idr

@@ -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