diff options
-rw-r--r-- | Untyped.hs (renamed from Main.hs) | 62 |
1 files changed, 26 insertions, 36 deletions
diff --git a/Main.hs b/Untyped.hs index eccb702..5e48ba3 100644 --- a/Main.hs +++ b/Untyped.hs @@ -1,31 +1,30 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - module Main where -import Text.ParserCombinators.Parsec (many1, sepBy1, string, noneOf, char, digit, spaces, sepEndBy, Parser, (<|>), parse, letter) -import Control.Monad (void) +import Text.ParserCombinators.Parsec (many1, sepBy1, string, noneOf, char, digit, spaces, sepEndBy, Parser, (<|>), parse, letter, oneOf) +--import Relude hiding ((<|>)) import Prelude +import Data.Foldable (foldl1) import qualified Data.Set as Set +import Control.Monad (forever, void) +import System.IO (hFlush, stdout) + data Term = Var String | App Term Term | Lam String Term deriving (Eq) instance Show Term where show (Var x) = x show (App x y) = show x ++ show y show (Lam x y) = "(λ"++x++". "++show y++")" -parens :: Parser a -> Parser a -parens p = char '(' *> spaces *> p <* spaces <* char ')' -var :: Parser Term +parens p = char '(' *> spaces *> p <* spaces <* char ')' var = Var <$> many1 letter - -lam :: Parser Term -lam = Lam <$> (char 'λ' *> spaces *> (many1 letter)) <*> (spaces *> string "." *> spaces *> term) - -app :: Parser Term +lam = do + void $ char '\\' + spaces + vars <- many1 $ (many1 letter) <* spaces + void $ string "." + spaces + body <- term + return (foldr Lam body vars) app = foldl1 App <$> sepBy1 (var <|> parens term) spaces - -term :: Parser Term term = lam <|> app <|> var fv :: Term -> Set.Set String @@ -34,40 +33,31 @@ fv (Lam x m) = x `Set.delete` (fv m) fv (App m1 m2) = (fv m1) `Set.union` (fv m2) pickFresh :: Set.Set String -> String -> String -pickFresh s = pickFresh' - where - pickFresh' n | n `Set.notMember` s = n - pickFresh' n = pickFresh' $ n ++ "'" +pickFresh s n | n `Set.notMember` s = n +pickFresh s n = pickFresh s $ n <> "'" -subst :: Term -> String -> Term -> Term subst n x (Var e) | x == e = n | otherwise = Var e subst n x (App m1 m2) = App (subst n x m1) (subst n x m2) -subst n x (Lam y m) - | x == y = Lam y m +subst n x l@(Lam y m) + | x == y = l | y `Set.notMember` (fv n) = Lam y (subst n x m) | otherwise = Lam y' (subst n x (subst (Var y') y m)) where y' = pickFresh ((fv n) `Set.union` (fv m)) y -normalstep :: Term -> Maybe Term normalstep (App (Lam x m) n) = Just (subst n x m) normalstep (Lam x m) = normalstep m >>= return . Lam x normalstep (App m n) | normalstep m == Nothing = normalstep n >>= return . App m normalstep (App m n) = normalstep m >>= return . (`App` n) normalstep _ = Nothing -repeatedly :: (a -> Maybe a) -> a -> [a] -repeatedly f = repeatedly' - where - repeatedly' x = - x : case f x of - Nothing -> [] - Just y -> repeatedly' y - -eval s = last <$> repeatedly normalstep <$> parse term "" s +repeatedly f x = maybe x (repeatedly f) (f x) +eval = (repeatedly normalstep <$>) . parse term "<stdin>" -main = do - contents <- getContents - putStrLn $ show $ eval contents +main = forever $ do + putStr "Untyped> " + hFlush stdout + contents <- getLine + putStrLn $ (either show show . eval) contents |