Add strings handling

4 files changed, 87 insertions, 17 deletions

diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs b/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs
index 1d2f9e8..d3c14e3 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs
@@ -5,13 +5,14 @@ module Minilang.Lambda.DeBruijn where
 import Data.List (elemIndex)
 import qualified Data.Map.Strict as Map
 import Data.Text (Text)
-import qualified Data.Text
+import qualified Data.Text as Text
 import Minilang.Lambda.Eval (Term)
 import qualified Minilang.Lambda.Eval as Eval
 
 data DeBruijn ann
   = FV Text
   | FNum Int
+  | FStr Text              -- ^ a string literal (closed value)
   | FBuiltin Text          -- ^ a fully-applied or partial built-in operator
   | Var ann Int
   | Lam ann (DeBruijn ann)
@@ -34,6 +35,7 @@ fromDeBruijn :: DeBruijn Text -> Term
 fromDeBruijn = \case
   FV x        -> Eval.Var x
   FNum n      -> Eval.Num n
+  FStr s      -> Eval.Str s
   FBuiltin b  -> Eval.Var b        -- reads back as a Var; eval recognises it
   Var s _     -> Eval.Var s
   Lam s body  -> Eval.Lam s (fromDeBruijn body)
@@ -53,6 +55,8 @@ toDeBruijn term = go term []
       App (go f env) (go a env)
     go (Eval.Num n) _env =
       FNum n
+    go (Eval.Str s) _env =
+      FStr s
 
 eval :: DeBruijn ann -> DeBruijn ann
 eval (App f a) =
@@ -66,6 +70,7 @@ eval' env = \case
   FV v -> case lookup v env of
     Just term -> term
     Nothing   -> FV v
+  FStr s     -> FStr s
   FBuiltin b -> FBuiltin b
   App f a ->
     let f' = eval' env f
@@ -136,6 +141,7 @@ churchFalse = Lam "f" (Lam "t" (Var "f" 1))
 -- Comparison operators return Church booleans rather than integer flags.
 tryReduce :: Text -> [DeBruijn Text] -> Maybe (DeBruijn Text)
 tryReduce name args = case (name, args) of
+  -- Integer arithmetic
   ("+",   [FNum x, FNum y]) -> Just $ FNum (x + y)
   ("-",   [FNum x, FNum y]) -> Just $ FNum (x - y)
   ("*",   [FNum x, FNum y]) -> Just $ FNum (x * y)
@@ -144,7 +150,13 @@ tryReduce name args = case (name, args) of
   ("=",   [FNum x, FNum y]) -> Just $ if x == y then churchTrue else churchFalse
   ("<",   [FNum x, FNum y]) -> Just $ if x <  y then churchTrue else churchFalse
   ("neg", [FNum x])         -> Just $ FNum (negate x)
-  _                         -> Nothing
+  -- String operations
+  ("str-concat", [FStr x, FStr y])         -> Just $ FStr (x <> y)
+  ("str-length", [FStr x])                 -> Just $ FNum (Text.length x)
+  ("str-slice",  [FNum i, FNum j, FStr x]) -> Just $ FStr (Text.take (j - i) (Text.drop i x))
+  ("str=",       [FStr x, FStr y])         -> Just $ if x == y then churchTrue else churchFalse
+  ("str<",       [FStr x, FStr y])         -> Just $ if x <  y then churchTrue else churchFalse
+  _                                        -> Nothing
 
 -- | Rebuild a left-spine application from a head and a list of arguments.
 rebuild :: DeBruijn Text -> [DeBruijn Text] -> DeBruijn Text
@@ -156,6 +168,7 @@ substitute env n arg term = case term of
     Just t  -> t
     Nothing -> FV x
   FNum _     -> term
+  FStr _     -> term
   FBuiltin _ -> term
   Var t x
     | x == n    -> arg
@@ -167,6 +180,7 @@ pretty :: DeBruijn Text -> Text
 pretty = \case
   FV x       -> x
   FNum n     -> showNum n
+  FStr s     -> "\"" <> escapeStr s <> "\""
   FBuiltin b -> b
   Var s _    -> s
   Lam s body -> "(lam (" <> s <> ") " <> pretty body <> ")"
@@ -175,5 +189,15 @@ pretty = \case
 -- | 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)
+  | n < 0     = "-" <> Text.pack (show (abs n))
+  | otherwise = Text.pack (show n)
+
+-- | Escape a string for pretty-printing: wrap in double-quotes and escape
+-- backslashes and double-quote characters so the output round-trips through
+-- the parser.
+escapeStr :: Text -> Text
+escapeStr = Text.concatMap escapeChar
+  where
+    escapeChar '"'  = "\\\""
+    escapeChar '\\' = "\\\\"
+    escapeChar c    = Text.singleton c
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
index 324c881..104fddc 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
@@ -8,6 +8,7 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.String (IsString (..))
 import Data.Text (Text, pack)
+import qualified Data.Text as Text
 import GHC.Generics (Generic)
 
 data Term
@@ -15,6 +16,7 @@ data Term
   | Lam Text Term
   | App Term Term
   | Num Int
+  | Str Text
   deriving (Show, Read, Eq, Generic, ToJSON, FromJSON)
 
 instance IsString Term where
@@ -27,10 +29,11 @@ data Value
   = Clos EnvValue Text Term
   | VNeut Neutral
   | VNum Int
+  | VStr Text
   | Builtin Text Int [Value]
   deriving (Show, Read, Eq)
 
-data Neutral = NVar Text | NNum Int | NApp Neutral Value
+data Neutral = NVar Text | NNum Int | NStr Text | NApp Neutral Value
   deriving (Show, Read, Eq)
 
 type Env = [(Text, Term)]
@@ -43,14 +46,19 @@ newEnv = []
 -- | Arity table for every built-in operator.
 builtinArity :: Map Text Int
 builtinArity = Map.fromList
-  [ ("+",   2)
-  , ("-",   2)
-  , ("*",   2)
-  , ("div", 2)
-  , ("mod", 2)
-  , ("=",   2)
-  , ("<",   2)
-  , ("neg", 1)
+  [ ("+",          2)
+  , ("-",          2)
+  , ("*",          2)
+  , ("div",        2)
+  , ("mod",        2)
+  , ("=",          2)
+  , ("<",          2)
+  , ("neg",        1)
+  , ("str-concat", 2)
+  , ("str-length", 1)
+  , ("str-slice",  3)
+  , ("str=",       2)
+  , ("str<",       2)
   ]
 
 -- | The set of built-in names, for fast membership testing.
@@ -77,6 +85,7 @@ eval env = \case
         a' = eval env a
      in f' `seq` a' `seq` apply f' a'
   Num n -> VNum n
+  Str s -> VStr s
 
 apply :: Value -> Value -> Value
 apply f a =
@@ -86,6 +95,7 @@ apply f a =
        in eval env' body
     VNeut f' -> VNeut (NApp f' a)
     VNum n   -> VNeut (NApp (NNum n) a)
+    VStr s   -> VNeut (NApp (NStr s) a)
     -- Last argument arrives: dispatch and reduce.
     Builtin name 1 args -> dispatchBuiltin name (args ++ [a])
     -- Still waiting for more arguments: accumulate.
@@ -105,6 +115,7 @@ churchFalse = Clos builtinEnvValue "f" (Lam "t" (Var "f"))
 -- Comparison operators (= and <) return Church booleans rather than integers.
 dispatchBuiltin :: Text -> [Value] -> Value
 dispatchBuiltin name args = case (name, args) of
+  -- Integer arithmetic
   ("+",   [VNum x, VNum y]) -> VNum (x + y)
   ("-",   [VNum x, VNum y]) -> VNum (x - y)
   ("*",   [VNum x, VNum y]) -> VNum (x * y)
@@ -115,6 +126,12 @@ dispatchBuiltin name args = case (name, args) of
   ("=",   [VNum x, VNum y]) -> if x == y then churchTrue else churchFalse
   ("<",   [VNum x, VNum y]) -> if x <  y then churchTrue else churchFalse
   ("neg", [VNum x])         -> VNum (negate x)
+  -- String operations
+  ("str-concat", [VStr x, VStr y])           -> VStr (x <> y)
+  ("str-length", [VStr x])                   -> VNum (Text.length x)
+  ("str-slice",  [VNum i, VNum j, VStr x])   -> VStr (Text.take (j - i) (Text.drop i x))
+  ("str=",       [VStr x, VStr y])           -> if x == y then churchTrue else churchFalse
+  ("str<",       [VStr x, VStr y])           -> if x <  y then churchTrue else churchFalse
   -- Stuck: reconstruct a neutral application chain rooted at the builtin name.
   _ -> foldl (\acc v -> VNeut (NApp (neutralOf acc) v)) (VNeut (NVar name)) args
   where
@@ -132,8 +149,10 @@ readBack = go []
          in Lam name (go names' val')
       VNeut (NVar n)    -> Var n
       VNeut (NNum n)    -> Num n
+      VNeut (NStr s)    -> Str s
       VNeut (NApp f a)  -> App (go names (VNeut f)) (go names a)
       VNum n            -> Num n
+      VStr s            -> Str s
       -- A partial builtin reads back as a chain of applications rooted at
       -- the builtin name, e.g. Builtin "+" 1 [VNum 3]  →  App (Var "+") (Num 3)
       Builtin bname _ accumulated ->
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Infer.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Infer.hs
index 2052398..9f0df35 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Infer.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Infer.hs
@@ -30,9 +30,14 @@ render :: TypeError -> Text
 render (UnifyError ue) = Unify.render ue
 
 fromTerm :: Eval.Term -> ATerm ()
-fromTerm (Eval.Var x) = Var x ()
+fromTerm (Eval.Var x)     = Var x ()
 fromTerm (Eval.Lam x body) = Lam x (fromTerm body) ()
-fromTerm (Eval.App a b) = App (fromTerm a) (fromTerm b) ()
+fromTerm (Eval.App a b)   = App (fromTerm a) (fromTerm b) ()
+-- Literal values (Num, Str) are treated as typed by a fresh variable;
+-- the inferencer only needs to traverse the term structure, not inspect
+-- literal payloads.
+fromTerm (Eval.Num _)     = Var "<num>" ()
+fromTerm (Eval.Str _)     = Var "<str>" ()
 
 infer :: Eval.Term -> Either TypeError Type
 infer t = do
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
index bf92daa..b2f011b 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
@@ -14,7 +14,7 @@ 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, optional, parse, some, try)
+import Text.Megaparsec (Parsec, between, empty, errorBundlePretty, manyTill, optional, parse, some, try)
 import Text.Megaparsec.Char (alphaNumChar, char, digitChar, letterChar, space1, symbolChar)
 import qualified Text.Megaparsec.Char.Lexer as L
 
@@ -26,6 +26,7 @@ data ParseError = ParseError Text
 data AST
   = Sym Text
   | Lit Int
+  | StrLit Text
   | Abs [Text] AST
   | App AST AST [AST]
   | Def Text AST
@@ -35,6 +36,7 @@ desugar :: AST -> Term
 desugar = \case
   Sym symb -> Eval.Var symb
   Lit n -> Eval.Num n
+  StrLit s -> Eval.Str s
   Abs bound body ->
     foldr
       Eval.Lam
@@ -52,6 +54,7 @@ resugar :: Term -> AST
 resugar = \case
   Eval.Var s -> Sym s
   Eval.Num n -> Lit n
+  Eval.Str s -> StrLit s
   Eval.Lam x body -> case resugar body of
     Abs vars ast -> Abs (x : vars) ast
     other -> Abs [x] other
@@ -67,10 +70,21 @@ pretty :: AST -> Text
 pretty = \case
   Sym symb -> symb
   Lit n -> prettyInt n
+  StrLit s -> "\"" <> escapeString s <> "\""
   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 <> ")"
 
+-- | Escape special characters in a string literal for pretty-printing.
+-- Only @\"@ and @\\@ need escaping; the parser uses 'L.charLiteral' which
+-- understands standard Haskell escape sequences.
+escapeString :: Text -> Text
+escapeString = Text.concatMap go
+  where
+    go '"'  = "\\\""
+    go '\\' = "\\\\"
+    go c    = Text.singleton c
+
 -- | Render an integer with no space between '-' and digits for negative numbers.
 prettyInt :: Int -> Text
 prettyInt n
@@ -87,7 +101,7 @@ parse =
   first (ParseError . pack . errorBundlePretty) . Text.Megaparsec.parse ast ""
 
 ast :: Parser AST
-ast = try defExpr <|> try letExpr <|> try lambda <|> try lit <|> try sym <|> try app
+ast = try defExpr <|> try letExpr <|> try lambda <|> try strLit <|> try lit <|> try sym <|> try app
 
 app :: Parser AST
 app =
@@ -163,6 +177,14 @@ lit = lexeme $ do
     Just _  -> negate n
     Nothing -> n
 
+-- | Parse a double-quoted string literal.
+-- Uses 'L.charLiteral' for each character so that standard Haskell escape
+-- sequences (e.g. @\"@, @\\@, @\n@, @\t@) are handled automatically.
+strLit :: Parser AST
+strLit = lexeme $ do
+  chars <- char '"' *> manyTill L.charLiteral (char '"')
+  pure $ StrLit $ pack chars
+
 sym :: Parser AST
 sym = Sym . pack <$> identifier