Day3 working

- Fix string and character encoding in output
- Fix autos not solving if another extends context

src/Lib/Compile.idr

@@ -171,28 +171,45 @@ 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 (show str)
+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",
   "function", "void", "undefined", "null", "await", "async", "return", "const",
-  "Number"
+  "Number", "default"
 ]
 
 ||| escape identifiers for js
 jsIdent : String -> Doc
 jsIdent id = if elem id keywords then text ("$" ++ id) else text $ pack $ fix (unpack id)
   where
-    chars : List Char
-    chars = unpack "0123456789ABCDEF"
 
-    toHex : Nat -> List Char
-    toHex 0 = []
-    toHex v = snoc (toHex (div v 16)) (fromMaybe ' ' (getAt (mod v 16) chars))
 
     fix : List Char -> List Char
     fix [] = []

src/Lib/Parser.idr

@@ -61,7 +61,7 @@ charLit : Parser Raw
 charLit = do
   fc <- getPos
   v <- token Character
-  pure $ RLit fc (LChar $ assert_total $ strIndex v 1)
+  pure $ RLit fc (LChar $ assert_total $ strIndex v 0)
 
 lit : Parser Raw
 lit = intLit <|> stringLit <|> charLit

src/Lib/ProcessDecl.idr

@@ -93,8 +93,8 @@ makeSpine (S k) (Bound :: xs) = makeSpine k xs :< VVar emptyFC k [<]
 makeSpine 0 xs = ?fixme
 
 solveAutos : Nat -> List MetaEntry -> M ()
-solveAutos mlen [] = pure ()
-solveAutos mlen ((Unsolved fc k ctx ty AutoSolve _) :: es) = do
+solveAutos mstart [] = pure ()
+solveAutos mstart ((Unsolved fc k ctx ty AutoSolve _) :: es) = do
       debug "AUTO solving \{show k} : \{show ty}"
       -- we want the context here too.
       top <- get
@@ -103,7 +103,7 @@ solveAutos mlen ((Unsolved fc k ctx ty AutoSolve _) :: es) = do
             xs => pure xs
         | res => do
           debug "FAILED to solve \{show ty}, matches: \{commaSep $ map (pprint [] . fst) res}"
-          solveAutos mlen es
+          solveAutos mstart es
         -- | res => error fc "FAILED to solve \{show ty}, matches: \{show $ map (pprint [] . fst) res}"
       writeIORef top.metas mc
       val <- eval ctx.env CBN tm
@@ -111,8 +111,9 @@ solveAutos mlen ((Unsolved fc k ctx ty AutoSolve _) :: es) = do
       let sp = makeSpine ctx.lvl ctx.bds
       solve ctx.env k sp val
       mc <- readIORef top.metas
-      solveAutos mlen (take mlen mc.metas)
-solveAutos mlen (_ :: es) = solveAutos mlen es
+      let mlen = length mc.metas `minus` mstart
+      solveAutos mstart (take mlen mc.metas)
+solveAutos mstart (_ :: es) = solveAutos mstart es
 
 dumpEnv : Context -> M String
 dumpEnv ctx =
@@ -218,7 +219,7 @@ processDecl (Def fc nm clauses) = do
 
   mc <- readIORef top.metas
   let mlen = length mc.metas `minus` mstart
-  solveAutos mlen (take mlen mc.metas)
+  solveAutos mstart (take mlen mc.metas)
   -- TODO - make nf that expands all metas and drop zonk
   -- Day1.newt is a test case
   -- tm' <- nf [] tm

src/Lib/Token.idr

@@ -42,6 +42,7 @@ Show Kind where
   show Pragma  = "Pragma"
   show StringKind = "String"
   show JSLit = "JSLit"
+
 export
 Eq Kind where
   Ident   == Ident = True

src/Lib/Tokenizer.idr

@@ -47,6 +47,17 @@ unquote str = case unpack str of
     go ('\\' :: (x :: xs)) = x :: go xs
     go (x :: xs) = x :: go xs
 
+unquoteChar : String -> String
+unquoteChar str = pack $ case unpack str of
+  ('\'' :: xs) => go xs
+  imp => go imp -- shouldn't happen
+  where
+    go : List Char -> List Char
+    go [] = ['\''] -- shouldn't happen
+    go ('\\' :: ('n' :: xs)) = ['\n']
+    go ('\\' :: (x :: xs)) = [x]
+    go (x :: xs) = [x]
+
 opMiddle = pred (\c => not (isSpace c || c == '_'))
 
 btick = is '`'
@@ -61,6 +72,11 @@ trimJS str = case unpack str of
     go ['`'] = []
     go (x :: xs) = x :: go xs
 
+%hide charLit
+charLit : Lexer
+charLit = is '\'' <+> (is '\\' <+> any <|> any) <+> is '\''
+
+
 rawTokens : Tokenizer (Token Kind)
 rawTokens
   = match spaces (Tok Space)
@@ -75,7 +91,7 @@ rawTokens
   -- REVIEW - expect non-alpha after?
   <|> match (some digit) (Tok Number)
   -- for module names and maybe type constructors
-  <|> match (charLit) (Tok Character)
+  <|> match (charLit) (Tok Character . unquoteChar)
   <|> match (is '#' <+> many alpha) (Tok Pragma)
   <|> match (lineComment (exact "--")) (Tok Space)
   <|> match (blockComment (exact "/-") (exact "-/")) (Tok Space)

src/Main.idr

@@ -43,7 +43,7 @@ writeSource : String -> M ()
 writeSource fn = do
   docs <- compile
   let src = unlines $
-        [ "#!/usr/bin/env node"
+        [ "\"use strict\";"
         ,  "const PiType = (h0, h1) => ({ tag: \"PiType\", h0, h1 })" ]
         ++ map (render 90) docs
         ++ [ "main();" ]