From fdf35536b66499884dd5b4e1740ac67e5cebb1a2 Mon Sep 17 00:00:00 2001
From: tzlil <tzlils@protonmail.com>
Date: Fri, 14 Apr 2023 23:46:53 +0300
Subject: add homework material

---
 src/AST.hs   | 28 +++++++++++++++++++
 src/HW.hs    | 50 +++++++++++++++++++++++++++++++++
 src/Parse.hs | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 169 insertions(+)
 create mode 100644 src/AST.hs
 create mode 100644 src/HW.hs
 create mode 100644 src/Parse.hs

(limited to 'src')

diff --git a/src/AST.hs b/src/AST.hs
new file mode 100644
index 0000000..456338e
--- /dev/null
+++ b/src/AST.hs
@@ -0,0 +1,28 @@
+-- | Abstract syntax tree for the untyped lambda calculus, plus some helpers.
+module AST (
+  Expr (..)
+) where
+
+-- | Lambda Expressions
+data Expr
+  = Var String
+  | Lam String Expr
+  | App Expr Expr
+  deriving (Eq, Ord)
+
+
+-- https://www.haskellforall.com/2020/11/pretty-print-syntax-trees-with-this-one.html
+showLam, showApp, showVar :: Expr -> String
+showLam (Lam i e) = "\\" ++ i ++ " . " ++ showLam e
+showLam e = showApp e
+
+showApp (App e1 e2) = showApp e1 ++ " " ++ showVar e2
+showApp e = showVar e
+
+showVar (Var i) = i
+showVar e = "(" ++ showLam e ++ ")"
+
+instance Show Expr where
+  show e = showLam e
+
+
diff --git a/src/HW.hs b/src/HW.hs
new file mode 100644
index 0000000..88fb1c2
--- /dev/null
+++ b/src/HW.hs
@@ -0,0 +1,50 @@
+module HW
+  ( fv
+  , subst
+  , normalstep
+  , pickFresh
+  , repeatedly 
+  , printnormal
+  ) where
+
+import AST
+import qualified Data.Set as Set
+import Parse (parse)
+
+-- | Return the free variables in an expression
+fv :: Expr -> Set.Set String
+fv _ = Set.singleton "UNIMPLEMENTED" -- Replace with your solution to problem 1
+
+
+
+-- | Substitute n for x in e, avoiding name capture
+--    subst n x e     e[x := n]
+subst :: Expr -> String -> Expr -> Expr
+subst _ _ _ = Var "UNIMPLEMENTED" -- Replace with your solution to problem 2
+
+
+
+-- | Take a single step in normal order reduction or return Nothing
+normalstep :: Expr -> Maybe Expr
+normalstep _ = Just (Var "UNIMPLEMENTED") -- Replace with your solution to problem 3
+
+
+
+
+-- | Return a "fresh" name not already in the set.
+-- Tries x' then x'', etc.
+pickFresh :: Set.Set String -> String -> String
+pickFresh s = pickFresh'
+  where pickFresh' n | n `Set.notMember` s = n
+        pickFresh' n                       = pickFresh' $ n ++ "'"
+               
+-- | Repeatedly apply a function to transform a value, returning the list
+-- of steps it took.  The result list starts with the given initial value
+repeatedly :: (a -> Maybe a) -> a -> [a]
+repeatedly f = repeatedly'
+  where repeatedly' x = x : case f x of Nothing -> []
+                                        Just y -> repeatedly' y
+
+-- | Print out the series of normal order reduction steps
+printnormal :: String -> IO ()
+printnormal = mapM_ print . repeatedly normalstep . parse
diff --git a/src/Parse.hs b/src/Parse.hs
new file mode 100644
index 0000000..748bd98
--- /dev/null
+++ b/src/Parse.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+-- | Parser for the untyped lambda calculus, whose AST is defined in "AST".
+module Parse (parse, tryParse) where
+
+import qualified AST as A
+
+import Text.Megaparsec (
+  MonadParsec (..),
+  Parsec,
+  errorBundlePretty,
+  noneOf,
+  runParser,
+  some,
+  (<?>),
+  (<|>),
+  between
+ )
+import Text.Megaparsec.Char( space1 )
+import qualified Text.Megaparsec.Char.Lexer as L
+
+import Control.Monad (void)
+import Data.Bifunctor (Bifunctor (..))
+import Data.Void (Void)
+
+-- * Exposed functions
+
+-- | Parse a Lambda expression; throw an exception over an error
+parse :: String -> A.Expr
+parse = either error id . tryParse
+
+-- | Parse some code 'String' into an 'L.Expr' or an error message.
+tryParse :: String -> Either String A.Expr
+tryParse = first errorBundlePretty .
+           runParser (pSpace >> pExpr <* eof) "<input>"
+
+{- * Expression parser
+
+Note that Megaparsec allows us to label tokens with 'label' or '(<?>)', which
+helps it produce human-readable error messages.
+-}
+
+-- | Entry point for parser.
+pExpr :: Parser A.Expr
+pExpr = pBody <?> "expression"
+
+-- | Parse expressions at the lowest level of precedence, i.e., lambdas.
+pBody :: Parser A.Expr
+pBody = pLam <|> pApp
+ where
+  pLam = do
+    pToken "\\"
+    bs <- some pIdent <?> "lambda binders"
+    pToken "."
+    body <- pBody <?> "lambda body"
+    return $ foldr A.Lam body bs
+
+-- | Parse juxtaposition as application.
+pApp :: Parser A.Expr
+pApp = foldl1 A.App <$> some pAtom <?> "term application"
+
+-- | Parse expressions at the highest precedence, including parenthesized terms
+pAtom :: Parser A.Expr
+pAtom = A.Var <$> pVar <|> pParens pExpr
+ where
+  pVar = pIdent <?> "variable"
+
+-- * Megaparsec boilerplate and helpers
+
+-- | Parsing monad.
+type Parser = Parsec Void String
+
+-- | Parse an identifier, possible surrounded by spaces
+pIdent :: Parser String
+pIdent = L.lexeme pSpace (some $ noneOf ['\\','.','(',')',' ','\n','\r','\t','-'])
+
+-- | Consume a token defined by a string, possibly surrounded by spaces
+pToken :: String -> Parser ()
+pToken = void . L.symbol pSpace
+
+-- | Parse some element surrounded by parentheses.
+pParens :: Parser a -> Parser a
+pParens = between (pToken "(") (pToken ")")
+
+-- | Consumes whitespace and comments.
+pSpace :: Parser ()
+pSpace = label "whitespace" $ L.space
+    space1
+    (L.skipLineComment "--")
+    (L.skipBlockCommentNested "{-" "-}")
-- 
cgit 1.4.1