Add integers parsing

3 files changed, 45 insertions, 6 deletions

diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs b/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs
index 025fd39..1e85ca6 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs
@@ -4,12 +4,13 @@ module Minilang.Lambda.DeBruijn where
 
 import Data.List (elemIndex)
 import Data.Text (Text)
+import qualified Data.Text
 import Minilang.Lambda.Eval (Term)
 import qualified Minilang.Lambda.Eval as Eval
-import Debug.Trace (trace)
 
 data DeBruijn ann
   = FV Text
+  | FNum Int
   | Var ann Int
   | Lam ann (DeBruijn ann)
   | App (DeBruijn ann) (DeBruijn ann)
@@ -23,6 +24,7 @@ newEnv = []
 fromDeBruijn :: DeBruijn Text -> Term
 fromDeBruijn = \case
   FV x -> Eval.Var x
+  FNum n -> Eval.Num n
   Var s _ -> Eval.Var s
   Lam s body -> Eval.Lam s (fromDeBruijn body)
   App f a -> Eval.App (fromDeBruijn f) (fromDeBruijn a)
@@ -39,6 +41,8 @@ toDeBruijn term = go term []
       Lam x (go body (x : env))
     go (Eval.App f a) env =
       App (go f env) (go a env)
+    go (Eval.Num n) _env =
+      FNum n
 
 eval :: DeBruijn ann -> DeBruijn ann
 eval (App f a) =
@@ -64,6 +68,7 @@ substitute env n arg term = case term of
   FV x -> case lookup x env of
     Just term -> term
     Nothing -> FV x
+  FNum _ -> term
   Var t x
     | x == n -> arg
     | otherwise -> Var t x
@@ -73,6 +78,13 @@ substitute env n arg term = case term of
 pretty :: DeBruijn Text -> Text
 pretty = \case
   FV x -> x
+  FNum n -> showNum n
   Var s _ -> s
   Lam s body -> "(lam (" <> s <> ") " <> pretty body <> ")"
   App f a -> "(" <> pretty f <> " " <> pretty a <> ")"
+
+-- | Render an integer, using no space between '-' and digits for negative numbers.
+showNum :: Int -> Text
+showNum n
+  | n < 0     = "-" <> Data.Text.pack (show (abs n))
+  | otherwise = Data.Text.pack (show n)
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
index e5530eb..650c4bd 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
@@ -12,15 +12,16 @@ data Term
   = Var Text
   | Lam Text Term
   | App Term Term
+  | Num Int
   deriving (Show, Read, Eq, Generic, ToJSON, FromJSON)
 
 instance IsString Term where
   fromString = Var . pack
 
-data Value = Clos EnvValue Text Term | VNeut Neutral
+data Value = Clos EnvValue Text Term | VNeut Neutral | VNum Int
   deriving (Show, Read, Eq)
 
-data Neutral = NVar Text | NApp Neutral Value
+data Neutral = NVar Text | NNum Int | NApp Neutral Value
   deriving (Show, Read, Eq)
 
 type Env = [(Text, Term)]
@@ -45,6 +46,7 @@ eval env = \case
     let f' = eval env f
         a' = eval env a
      in f' `seq` a' `seq` apply f' a'
+  Num n -> VNum n
 
 apply :: Value -> Value -> Value
 apply f a =
@@ -53,6 +55,7 @@ apply f a =
       let env' = (x, a) : closureEnv
        in eval env' body
     VNeut f' -> VNeut (NApp f' a)
+    VNum n -> VNeut (NApp (NNum n) a)
 
 readBack :: Value -> Term
 readBack = go []
@@ -64,7 +67,9 @@ readBack = go []
             val' = eval ((x, VNeut (NVar name)) : env) body
          in Lam name (go names' val')
       VNeut (NVar n) -> Var n
+      VNeut (NNum n) -> Num n
       VNeut (NApp f a) -> App (go names (VNeut f)) (go names a)
+      VNum n -> Num n
 
 freshName :: Text -> [Text] -> Text
 freshName x names
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
index a0cc577..bf92daa 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
@@ -14,8 +14,8 @@ import Data.Void (Void)
 import GHC.Generics (Generic)
 import Minilang.Lambda.Eval (Term)
 import qualified Minilang.Lambda.Eval as Eval
-import Text.Megaparsec (Parsec, between, empty, errorBundlePretty, parse, some, try)
-import Text.Megaparsec.Char (alphaNumChar, char, letterChar, space1, symbolChar)
+import Text.Megaparsec (Parsec, between, empty, errorBundlePretty, optional, parse, some, try)
+import Text.Megaparsec.Char (alphaNumChar, char, digitChar, letterChar, space1, symbolChar)
 import qualified Text.Megaparsec.Char.Lexer as L
 
 type Parser = Parsec Void Text
@@ -25,6 +25,7 @@ data ParseError = ParseError Text
 
 data AST
   = Sym Text
+  | Lit Int
   | Abs [Text] AST
   | App AST AST [AST]
   | Def Text AST
@@ -33,6 +34,7 @@ data AST
 desugar :: AST -> Term
 desugar = \case
   Sym symb -> Eval.Var symb
+  Lit n -> Eval.Num n
   Abs bound body ->
     foldr
       Eval.Lam
@@ -49,6 +51,7 @@ desugar = \case
 resugar :: Term -> AST
 resugar = \case
   Eval.Var s -> Sym s
+  Eval.Num n -> Lit n
   Eval.Lam x body -> case resugar body of
     Abs vars ast -> Abs (x : vars) ast
     other -> Abs [x] other
@@ -63,10 +66,17 @@ resugar = \case
 pretty :: AST -> Text
 pretty = \case
   Sym symb -> symb
+  Lit n -> prettyInt n
   Abs bound body -> "(lam (" <> Text.unwords bound <> ") " <> pretty body <> ")"
   App x y rest -> "(" <> mconcat (List.intersperse " " (pretty <$> (x : y : rest))) <> ")"
   Def name body -> "(def " <> name <> " " <> pretty body <> ")"
 
+-- | Render an integer with no space between '-' and digits for negative numbers.
+prettyInt :: Int -> Text
+prettyInt n
+  | n < 0     = "-" <> Text.pack (show (abs n))
+  | otherwise = Text.pack (show n)
+
 parseProgram :: Text -> Either ParseError [AST]
 parseProgram input =
   first (ParseError . pack . errorBundlePretty) $
@@ -77,7 +87,7 @@ parse =
   first (ParseError . pack . errorBundlePretty) . Text.Megaparsec.parse ast ""
 
 ast :: Parser AST
-ast = try defExpr <|> try letExpr <|> try lambda <|> try sym <|> try app
+ast = try defExpr <|> try letExpr <|> try lambda <|> try lit <|> try sym <|> try app
 
 app :: Parser AST
 app =
@@ -141,6 +151,18 @@ rpar = symbol ")"
 symbol :: Text -> Parser Text
 symbol = L.symbol spaceConsumer
 
+-- | Parse an integer literal.  The minus sign, if present, must immediately
+-- precede the digits with no intervening whitespace; this distinguishes @-7@
+-- (a negative number) from @- 7@ (the identifier @-@ applied to @7@).
+lit :: Parser AST
+lit = lexeme $ do
+  sign <- optional (char '-')
+  digits <- some digitChar
+  let n = read digits
+  pure $ Lit $ case sign of
+    Just _  -> negate n
+    Nothing -> n
+
 sym :: Parser AST
 sym = Sym . pack <$> identifier