From 54bcc4595f28ba76384b5f018d72bca353cd88d3 Mon Sep 17 00:00:00 2001 From: tzlil Date: Sat, 15 Apr 2023 01:54:47 +0300 Subject: fourmolu formatting --- src/AST.hs | 17 ++++++----------- src/HW.hs | 55 ++++++++++++++++++++++++++++++------------------------- src/Parse.hs | 55 +++++++++++++++++++++++++++++-------------------------- 3 files changed, 65 insertions(+), 62 deletions(-) (limited to 'src') diff --git a/src/AST.hs b/src/AST.hs index 456338e..6f21d9e 100644 --- a/src/AST.hs +++ b/src/AST.hs @@ -1,28 +1,23 @@ -- | Abstract syntax tree for the untyped lambda calculus, plus some helpers. module AST ( - Expr (..) + Expr (..), ) where -- | Lambda Expressions data Expr - = Var String - | Lam String Expr - | App Expr Expr - deriving (Eq, Ord) - + = 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 - - + show e = showLam e diff --git a/src/HW.hs b/src/HW.hs index ee26584..7e4e579 100644 --- a/src/HW.hs +++ b/src/HW.hs @@ -1,11 +1,11 @@ -module HW - ( fv - , subst - , normalstep - , pickFresh - , repeatedly - , printnormal - ) where +module HW ( + fv, + subst, + normalstep, + pickFresh, + repeatedly, + printnormal, +) where import AST import qualified Data.Set as Set @@ -17,33 +17,38 @@ fv (Var x) = Set.singleton x fv (Lam x m) = x `Set.delete` (fv m) fv (App m1 m2) = (fv m1) `Set.union` (fv m2) --- | Substitute n for x in e, avoiding name capture --- subst n x e e[x := n] +{- | 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 - - +-- subst _ _ _ = Var "UNIMPLEMENTED" -- Replace with your solution to problem 2 +subst n x (Var e) + | x == e = n + | otherwise = Var e -- | 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. +{- | 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 + 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 + 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 () diff --git a/src/Parse.hs b/src/Parse.hs index 748bd98..c06b20a 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -7,17 +7,17 @@ module Parse (parse, tryParse) where import qualified AST as A import Text.Megaparsec ( - MonadParsec (..), - Parsec, - errorBundlePretty, - noneOf, - runParser, - some, - (), - (<|>), - between + MonadParsec (..), + Parsec, + between, + errorBundlePretty, + noneOf, + runParser, + some, + (), + (<|>), ) -import Text.Megaparsec.Char( space1 ) +import Text.Megaparsec.Char (space1) import qualified Text.Megaparsec.Char.Lexer as L import Control.Monad (void) @@ -32,8 +32,9 @@ 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) "" +tryParse = + first errorBundlePretty + . runParser (pSpace >> pExpr <* eof) "" {- * Expression parser @@ -48,13 +49,13 @@ 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 + 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 @@ -63,8 +64,8 @@ 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" + where + pVar = pIdent "variable" -- * Megaparsec boilerplate and helpers @@ -73,7 +74,7 @@ type Parser = Parsec Void String -- | Parse an identifier, possible surrounded by spaces pIdent :: Parser String -pIdent = L.lexeme pSpace (some $ noneOf ['\\','.','(',')',' ','\n','\r','\t','-']) +pIdent = L.lexeme pSpace (some $ noneOf ['\\', '.', '(', ')', ' ', '\n', '\r', '\t', '-']) -- | Consume a token defined by a string, possibly surrounded by spaces pToken :: String -> Parser () @@ -85,7 +86,9 @@ pParens = between (pToken "(") (pToken ")") -- | Consumes whitespace and comments. pSpace :: Parser () -pSpace = label "whitespace" $ L.space - space1 - (L.skipLineComment "--") - (L.skipBlockCommentNested "{-" "-}") +pSpace = + label "whitespace" $ + L.space + space1 + (L.skipLineComment "--") + (L.skipBlockCommentNested "{-" "-}") -- cgit 1.4.1