push

Interpreter.hs

@@ -0,0 +1,65 @@
+module Interpreter (interFile) where
+
+import qualified Data.Map.Strict as Map
+import Lexer (lexL)
+import Parser (AstNode(..), parse)
+
+interFile :: FilePath -> IO ()
+interFile path = do
+  putStrLn $ "Interpreting " ++ path
+  content <- readFile path
+  let ls = zip [1..] (lines content)
+  mapM_ (uncurry interLine) ls
+
+interLine :: Int -> String -> IO ()
+interLine lineNum line =
+  case lexL lineNum line of
+    Left e  -> error $ "Lexer error: " ++ e
+    Right toks ->
+      case parse toks of
+        Left e  -> error $ "Parser error: " ++ e
+        Right ast ->
+          case ast of
+            Epsilon -> return ()
+            _ -> do
+              let result = evaluate ast
+              putStrLn $ show ast ++ " => " ++ show result
+
+evaluate :: AstNode -> AstNode
+evaluate ast =
+  let ast' = reduce ast Map.empty
+  in if ast' == ast then ast else evaluate ast'
+
+reduce :: AstNode -> Map.Map String AstNode -> AstNode
+reduce (Abstraction p t) env =
+  case p of
+    Identifier pid ->
+      let env' = Map.delete pid env
+      in case t of
+           Application tl tr
+             | tr == p && not (isFree tl p) -> reduce tl env'
+           _ -> Abstraction p (reduce t env')
+    _ -> error "Invalid abstraction"
+
+reduce (Application l r) env =
+  case l of
+    Abstraction p body ->
+      case p of
+        Identifier pid ->
+          let env' = Map.insert pid (reduce r env) env
+          in reduce body env'
+        _ -> error "Invalid application"
+    _ -> Application (reduce l env) (reduce r env)
+
+reduce (Identifier id_) env =
+  case Map.lookup id_ env of
+    Just x  -> x
+    Nothing -> Identifier id_
+
+reduce Epsilon _ = Epsilon
+
+isFree :: AstNode -> AstNode -> Bool
+isFree (Abstraction p t) id_ = id_ /= p && isFree t id_
+isFree (Application l r) id_ = isFree l id_ || isFree r id_
+isFree (Identifier s)    id_ = Identifier s == id_
+isFree _                 _   = False

Lexer.hs

@@ -0,0 +1,115 @@
+module Lexer
+  ( TokenType(..)
+  , Token(..)
+  , lexL
+  ) where
+
+import Data.Char (isAlphaNum)
+
+data TokenType
+  = Lambda
+  | Dot
+  | Identifier
+  | OpenParen
+  | CloseParen
+  | EOF
+  deriving (Show, Eq)
+
+data Token = Token
+  { tokType  :: TokenType
+  , tokLine  :: Int
+  , tokCol   :: Int
+  , tokLexeme :: String
+  } deriving (Show)
+
+data LexState = LexState
+  { src  :: String
+  , col  :: Int
+  , line :: Int
+  }
+
+type LexResult = Either String (Maybe Token, LexState)
+
+iic :: Char -> Bool
+iic c = isAlphaNum c || c == '_'
+
+isIgnoreChar :: Char -> Bool
+isIgnoreChar c = c `elem` "() \t"
+
+peek :: LexState -> Either String Char
+peek st = case drop (col st) (src st) of
+  []    -> Left "Out of characters"
+  (c:_) -> Right c
+
+mkToken :: LexState -> TokenType -> Int -> Either String Token
+mkToken st ttype start
+  | ttype == EOF =
+      Right $ Token ttype (line st) start (drop start (take (col st) (src st)))
+  | start < length (src st) && col st > 0 && col st - 1 < length (src st) =
+      Right $ Token ttype (line st) start (drop start (take (col st) (src st)))
+  | otherwise =
+      Left $ "Failed to resolve " ++ show ttype ++
+             ". Line " ++ show (line st) ++ ", " ++ show start ++ ":" ++ show (col st)
+
+advance :: LexState -> LexState
+advance st = st { col = col st + 1 }
+
+isEol :: LexState -> Bool
+isEol st = col st >= length (src st)
+
+lexC :: LexState -> LexResult
+lexC st
+  | isEol st  = Right (Nothing, st)
+  | otherwise = lexC (advance st)
+
+lexIdent :: LexState -> LexResult
+lexIdent st =
+  let start = col st
+      st'   = scanIdent st
+  in case mkToken st' Identifier start of
+       Left e  -> Left e
+       Right t -> Right (Just t, st')
+  where
+    scanIdent s
+      | isEol s   = s
+      | otherwise = case peek s of
+          Right c | iic c -> scanIdent (advance s)
+          _                       -> s
+
+lexS :: LexState -> TokenType -> LexResult
+lexS st ttype =
+  let st' = advance st
+  in case mkToken st' ttype (col st) of
+       Left e  -> Left e
+       Right t -> Right (Just t, st')
+
+lexToken :: LexState -> LexResult
+lexToken st = case peek st of
+  Left e  -> Left e
+  Right c -> case c of
+    'λ'               -> lexS st Lambda
+    '\\'              -> lexS st Lambda
+    '.'               -> lexS st Dot
+    '('               -> lexS st OpenParen
+    ')'               -> lexS st CloseParen
+    '#'               -> lexC st
+    _ | iic c -> lexIdent st
+    _ | isIgnoreChar c -> Right (Nothing, advance st)
+    _                 -> Left $ "Bad character. Line " ++ show (line st) ++
+                                ", column " ++ show (col st)
+
+lexAll :: LexState -> Either String ([Token], LexState)
+lexAll st
+  | isEol st  = Right ([], st)
+  | otherwise = case lexToken st of
+      Left e         -> Left e
+      Right (mt, st') -> case lexAll st' of
+        Left e           -> Left e
+        Right (ts, st'') -> Right (maybe ts (:ts) mt, st'')
+
+lexL :: Int -> String -> Either String [Token]
+lexL lineNum input = do
+  let st = LexState { src = input, col = 0, line = lineNum }
+  (tokens, st') <- lexAll st
+  let eofTok = Token EOF (line st') (col st') ""
+  return (tokens ++ [eofTok])

Main.hs

@@ -0,0 +1,11 @@
+module Main where
+
+import System.Environment (getArgs)
+import Interpreter (interFile)
+
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    [path] -> interFile path
+    _      -> putStrLn "Usage: lambda-calc <file_path>"

Parser.hs

@@ -0,0 +1,138 @@
+module Parser
+  ( AstNode(..)
+  , parse
+  ) where
+
+import qualified Data.Map.Strict as Map
+import Lexer (Token(..), TokenType)
+import qualified Lexer as L
+
+-- AST
+data AstNode
+  = Abstraction { parameter :: AstNode, term :: AstNode }
+  | Application { lhs :: AstNode, rhs :: AstNode }
+  | Identifier String
+  | Epsilon
+  deriving (Eq)
+
+instance Show AstNode where
+  show (Application l r) = "(" ++ show l ++ " " ++ show r ++ ")"
+  show (Abstraction p t) = "λ" ++ show p ++ "." ++ show t
+  show (Identifier s)    = s
+  show Epsilon           = "ε"
+
+reduce :: AstNode -> Map.Map String AstNode -> AstNode
+reduce (Abstraction p t) env =
+  case p of
+    Identifier pid ->
+      let env' = Map.delete pid env
+      in case t of
+           Application tl tr
+             | tr == p && not (isFree tl p) -> reduce tl env'
+           _ -> Abstraction p (reduce t env')
+    _ -> error "Invalid abstraction"
+
+reduce (Application l r) env =
+  case l of
+    Abstraction p body ->
+      case p of
+        Identifier pid ->
+          let env' = Map.insert pid (reduce r env) env
+          in reduce body env'
+        _ -> error "Invalid application"
+    _ -> Application (reduce l env) (reduce r env)
+
+reduce (Identifier id_) env =
+  case Map.lookup id_ env of
+    Just x  -> x
+    Nothing -> Identifier id_
+
+reduce Epsilon _ = Epsilon
+
+isFree :: AstNode -> AstNode -> Bool
+isFree (Abstraction p t) id_ = id_ /= p && isFree t id_
+isFree (Application l r) id_ = isFree l id_ || isFree r id_
+isFree (Identifier s)    id_ = Identifier s == id_
+isFree _                 _   = False
+
+-- Parser state
+data ParseState = ParseState
+  { tokens :: [Token]
+  , idx    :: Int
+  }
+
+type ParseResult = Either String AstNode
+
+peekTok :: ParseState -> Either String Token
+peekTok ps = case drop (idx ps) (tokens ps) of
+  []    -> Left "Out of tokens"
+  (t:_) -> Right t
+
+advanceP :: ParseState -> ParseState
+advanceP ps = ps { idx = idx ps + 1 }
+
+consume :: ParseState -> TokenType -> Either String (Token, ParseState)
+consume ps expected = do
+  t <- peekTok ps
+  if tokType t /= expected
+    then Left $ "Unexpected token. Expected " ++ show expected ++
+                ", but found " ++ show (tokType t)
+    else Right (t, advanceP ps)
+
+parseIdentifier :: ParseState -> Either String (AstNode, ParseState)
+parseIdentifier ps = do
+  (t, ps') <- consume ps L.Identifier
+  return (Identifier (tokLexeme t), ps')
+
+parseAbstraction :: ParseState -> Either String (AstNode, ParseState)
+parseAbstraction ps = do
+  (_, ps1) <- consume ps L.Lambda
+  (ident, ps2) <- parseIdentifier ps1
+  (_, ps3) <- consume ps2 L.Dot
+  (t, ps4) <- parseTerm ps3
+  return (Abstraction ident t, ps4)
+
+parseAtom :: ParseState -> Maybe (Either String (AstNode, ParseState))
+parseAtom ps = case peekTok ps of
+  Left e  -> Just (Left ("Error parsing atom. " ++ e))
+  Right t -> case tokType t of
+    L.Identifier -> Just (parseIdentifier ps)
+    L.OpenParen  -> Just (pGT ps)
+    _            -> Nothing
+
+pA :: ParseState -> Either String (AstNode, ParseState)
+pA ps = do
+  (l0, ps') <- parseAtomOrFail ps
+  go l0 ps'
+  where
+    parseAtomOrFail s = case parseAtom s of
+      Just r  -> r
+      Nothing -> Left "Expected atom"
+    go lhs_ ps_ = case parseAtom ps_ of
+      Nothing       -> Right (lhs_, ps_)
+      Just (Left e) -> Left e
+      Just (Right (r, ps_')) -> go (Application lhs_ r) ps_'
+
+pGT :: ParseState -> Either String (AstNode, ParseState)
+pGT ps = do
+  (_, ps1) <- consume ps L.OpenParen
+  (t, ps2) <- parseTerm ps1
+  (_, ps3) <- consume ps2 L.CloseParen
+  return (t, ps3)
+
+Epsilon :: ParseState -> Either String (AstNode, ParseState)
+Epsilon ps = Right (Epsilon, advanceP ps)
+
+parseTerm :: ParseState -> Either String (AstNode, ParseState)
+parseTerm ps = do
+  t <- peekTok ps
+  case tokType t of
+    L.EOF        -> Epsilon ps
+    L.CloseParen -> Epsilon ps
+    L.Lambda     -> parseAbstraction ps
+    _            -> pA ps
+
+parse :: [Token] -> Either String AstNode
+parse toks = do
+  (ast, _) <- parseTerm (ParseState toks 0)
+  return ast