summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lambda-calcul/haskell/src/Minilang/IO.hs28
-rw-r--r--lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs43
-rw-r--r--lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs29
-rw-r--r--lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs14
4 files changed, 61 insertions, 53 deletions
diff --git a/lambda-calcul/haskell/src/Minilang/IO.hs b/lambda-calcul/haskell/src/Minilang/IO.hs
index a045647..b2b3dcc 100644
--- a/lambda-calcul/haskell/src/Minilang/IO.hs
+++ b/lambda-calcul/haskell/src/Minilang/IO.hs
@@ -7,8 +7,8 @@ import Data.Text.Encoding
encodeUtf8,
)
import Data.Text.Encoding.Error (lenientDecode)
-import Minilang.Lambda.DeBruijn (eval, toDeBruijn)
-import Minilang.Lambda.Parser (desugar, parse, pretty)
+import Minilang.Lambda.DeBruijn (eval, fromDeBruijn, toDeBruijn)
+import Minilang.Lambda.Parser (desugar, parse, pretty, resugar)
import System.IO (Handle)
-- | Read a "program" from @hin@ handle, evaluate it and dump the result
@@ -17,11 +17,19 @@ runEval :: Handle -> Handle -> IO ()
runEval hin hout = do
programText <- decodeUtf8With lenientDecode <$> BS.hGetContents hin
let parsed = parse programText
- case parsed of
- Left err -> print err
- Right ast -> do
- putStrLn $ Text.unpack $ "Evaluating " <> pretty ast
- let termy = desugar ast
- putStrLn $ "Desugared to " <> show termy
- let term = toDeBruijn termy
- print $ eval term
+ let result =
+ case parsed of
+ Left err -> Text.pack $ show err
+ Right ast ->
+ let evaluate =
+ pretty
+ . resugar
+ . fromDeBruijn
+ . eval
+ . toDeBruijn
+ . desugar
+ in evaluate ast
+
+ BS.hPut
+ hout
+ (encodeUtf8 result)
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs b/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs
index 6b5b7a2..290839e 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/DeBruijn.hs
@@ -1,42 +1,57 @@
+{-# LANGUAGE LambdaCase #-}
module Minilang.Lambda.DeBruijn where
import Data.List (elemIndex)
-import Data.Text (Text)
+import Data.Text (Text, unpack, pack)
import Minilang.Lambda.Eval (Term)
import qualified Minilang.Lambda.Eval as Eval
-data DeBruijn
+data DeBruijn ann
= FV Text
- | Var Int
- | Lam DeBruijn
- | App DeBruijn DeBruijn
+ | Var ann Int
+ | Lam ann (DeBruijn ann)
+ | App (DeBruijn ann) (DeBruijn ann)
deriving (Show, Read, Eq)
+fromDeBruijn :: DeBruijn Text -> Term
+fromDeBruijn = \case
+ FV x -> Eval.Var x
+ Var s _ -> Eval.Var s
+ Lam s body -> Eval.Lam s (fromDeBruijn body)
+ App f a -> Eval.App (fromDeBruijn f) (fromDeBruijn a)
+
-- Convert a term with named variables to De Bruijn indices
-toDeBruijn :: Term -> DeBruijn
+toDeBruijn :: Term -> DeBruijn Text
toDeBruijn term = go term []
where
go (Eval.Var x) env =
case elemIndex x env of
- Just idx -> Var idx
+ Just idx -> Var x idx
Nothing -> FV x
go (Eval.Lam x body) env =
- Lam (go body (x : env))
+ Lam x (go body (x : env))
go (Eval.App f a) env =
App (go f env) (go a env)
-eval :: DeBruijn -> DeBruijn
+eval :: DeBruijn ann -> DeBruijn ann
eval (App f a) =
case eval f of
- Lam body -> eval (substitute 0 a body)
+ Lam _ body -> eval (substitute 0 a body)
f' -> App f' a
eval term = term
-substitute :: Int -> DeBruijn -> DeBruijn -> DeBruijn
+substitute :: Int -> DeBruijn ann -> DeBruijn ann -> DeBruijn ann
substitute n arg term = case term of
FV x -> FV x
- Var x
+ Var t x
| x == n -> arg
- | otherwise -> Var x
- Lam body -> Lam (substitute (n + 1) arg body)
+ | otherwise -> Var t x
+ Lam x body -> Lam x (substitute (n + 1) arg body)
App f a -> App (substitute n arg f) (substitute n arg a)
+
+pretty :: DeBruijn Text -> Text
+pretty = \case
+ FV x -> x
+ Var s _ -> s
+ Lam s body -> "(lam (" <> s <> ") " <> pretty body <> ")"
+ App f a -> "(" <> pretty f <> " " <> pretty a <> ")"
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
index 35f9460..cbbdc51 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs
@@ -42,32 +42,3 @@ evalNeed (App f a) env =
in case evalNeed f env of
Abs x body env' -> evalNeed body ((x, a') : env')
f' -> Ap f' a'
-
-x =
- App
- ( App
- ( App
- ( App
- ( App
- ( App
- ( App
- ( App
- ( App
- (Lam "False" (Lam "True" (Lam "If" (Lam "Zero" (Lam "Succ" (Lam "One" (Lam "Two" (Lam "Three" (Lam "IsZero" (App (Var "IsZero") (Var "Two")))))))))))
- (Lam "f" (Lam "t" (Var "f")))
- )
- (Lam "f" (Lam "t" (Var "t")))
- )
- (Lam "b" (Lam "x" (Lam "y" (App (App (Var "b") (Var "x")) (Var "y")))))
- )
- (Lam "z" (Lam "s" (Var "z")))
- )
- (Lam "n" (Lam "z" (Lam "s" (App (Var "s") (Var "n")))))
- )
- (App (Var "Succ") (Var "Zero"))
- )
- (App (Var "Succ") (Var "One"))
- )
- (App (Var "Succ") (Var "Two"))
- )
- (Lam "n" (App (App (Var "n") (Var "True")) (Lam "m" (Var "False"))))
diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
index e52c981..fd02ebe 100644
--- a/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
+++ b/lambda-calcul/haskell/src/Minilang/Lambda/Parser.hs
@@ -37,6 +37,20 @@ desugar = \case
(Eval.App (desugar x) (desugar y))
rest
+resugar :: Term -> AST
+resugar = \case
+ Eval.Var s -> Sym s
+ Eval.Lam x body -> case resugar body of
+ Abs vars ast -> Abs (x : vars) ast
+ other -> Abs [x] other
+ Eval.App l r -> case resugar l of
+ App f a rest -> App f a (rest ++ [r'])
+ where
+ r' = resugar r
+ other -> App other r' []
+ where
+ r' = resugar r
+
pretty :: AST -> Text
pretty = \case
Sym symb -> symb
generated by cgit v1.3.1 (git 2.54.0) at 2026-10-24 05:31:12 +0000