commit e6e05b607a95493fbcc88540b70adb80360ed9cb
parent 63aa977efd424522f49bd6ba29dc2e3f4ceee0d4
Author: James Eversole <james@eversole.co>
Date: Sun, 19 Jan 2025 14:41:25 -0600
General refactor for legibility
Priming to update all source to lhs and document extensively
Diffstat:
6 files changed, 127 insertions(+), 171 deletions(-)
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -8,110 +8,87 @@ import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
-evalSingle :: Map String T -> TricuAST -> Map String T
-evalSingle env term = case term of
- SFunc name [] body ->
- let lineNoLambda = eliminateLambda body
- result = evalAST env lineNoLambda
- in Map.insert "__result" result (Map.insert name result env)
- SLambda _ body ->
- let result = evalAST env body
- in Map.insert "__result" result env
- SApp func arg ->
- let result = apply (evalAST env $ eliminateLambda func) (evalAST env $ eliminateLambda arg)
- in Map.insert "__result" result env
- SVar name ->
- case Map.lookup name env of
- Just value -> Map.insert "__result" value env
+evalSingle :: Env -> TricuAST -> Env
+evalSingle env term
+ | SFunc name [] body <- term =
+ let res = evalAST env $ elimLambda body
+ in Map.insert "__result" res (Map.insert name res env)
+ | SLambda _ body <- term = Map.insert "__result" (evalAST env body) env
+ | SApp func arg <- term = Map.insert "__result"
+ (apply (evalAST env $ elimLambda func) (evalAST env $ elimLambda arg)) env
+ | SVar name <- term = case Map.lookup name env of
+ Just v -> Map.insert "__result" v env
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
- _ ->
- let result = evalAST env term
- in Map.insert "__result" result env
+ | otherwise = Map.insert "__result" (evalAST env term) env
-evalTricu :: Map String T -> [TricuAST] -> Map String T
+evalTricu :: Env -> [TricuAST] -> Env
evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
where
- evalTricu' :: Map String T -> [TricuAST] -> Map String T
- evalTricu' env [] = env
- evalTricu' env [lastLine] =
- let lastLineNoLambda = eliminateLambda lastLine
- updatedEnv = evalSingle env lastLineNoLambda
- in Map.insert "__result" (result updatedEnv) updatedEnv
- evalTricu' env (line:rest) =
- let lineNoLambda = eliminateLambda line
- updatedEnv = evalSingle env lineNoLambda
- in evalTricu updatedEnv rest
+ evalTricu' :: Env -> [TricuAST] -> Env
+ evalTricu' env [] = env
+ evalTricu' env [s] =
+ let updatedEnv = evalSingle env $ elimLambda s
+ in Map.insert "__result" (result updatedEnv) updatedEnv
+ evalTricu' env (x:xs) = evalTricu (evalSingle env $ elimLambda x) xs
-evalAST :: Map String T -> TricuAST -> T
-evalAST env term = case term of
- SVar name -> case Map.lookup name env of
- Just value -> value
- Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
- TLeaf -> Leaf
- TStem t -> Stem (evalAST env t)
- TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
- SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
- SStr str -> ofString str
- SInt num -> ofNumber num
- SList elems -> ofList (map (evalAST env) elems)
- SEmpty -> Leaf
- SFunc name args body ->
- errorWithoutStackTrace $ "Unexpected function definition " ++ name
- SLambda {} -> errorWithoutStackTrace "Internal error: SLambda found in evalAST after elimination."
-
-eliminateLambda :: TricuAST -> TricuAST
-eliminateLambda (SLambda (v:vs) body)
- | null vs = lambdaToT v (eliminateLambda body)
- | otherwise = eliminateLambda (SLambda [v] (SLambda vs body))
-eliminateLambda (SApp f arg) = SApp (eliminateLambda f) (eliminateLambda arg)
-eliminateLambda (TStem t) = TStem (eliminateLambda t)
-eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r)
-eliminateLambda (SList xs) = SList (map eliminateLambda xs)
-eliminateLambda other = other
+evalAST :: Env -> TricuAST -> T
+evalAST env term
+ | SVar name <- term = evalVar name
+ | TLeaf <- term = Leaf
+ | TStem t <- term = Stem (evalAST env t)
+ | TFork t u <- term = Fork (evalAST env t) (evalAST env u)
+ | SApp t u <- term = apply (evalAST env t) (evalAST env u)
+ | SStr s <- term = ofString s
+ | SInt n <- term = ofNumber n
+ | SList xs <- term = ofList (map (evalAST env) xs)
+ | SEmpty <- term = Leaf
+ | otherwise = errorWithoutStackTrace "Unexpected AST term"
+ where
+ evalVar name = Map.findWithDefault
+ (errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
+ name env
-- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
-- Chapter 4: Lambda-Abstraction
-lambdaToT :: String -> TricuAST -> TricuAST
-lambdaToT x (SVar y)
- | x == y = tI
-lambdaToT x (SVar y)
- | x /= y = SApp tK (SVar y)
-lambdaToT x t
- | not (isFree x t) = SApp tK t
-lambdaToT x (SApp n u)
- | not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
-lambdaToT x (SApp n u) = SApp (SApp tS (lambdaToT x (eliminateLambda n))) (lambdaToT x (eliminateLambda u))
-lambdaToT x body
- | not (isFree x body) = SApp tK body
- | otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
-
-freeVars :: TricuAST -> Set.Set String
-freeVars (SVar v) = Set.singleton v
-freeVars (SInt _) = Set.empty
-freeVars (SStr _) = Set.empty
-freeVars (SList xs) = foldMap freeVars xs
-freeVars (SApp f arg) = freeVars f <> freeVars arg
-freeVars TLeaf = Set.empty
-freeVars (SFunc _ _ b) = freeVars b
-freeVars (TStem t) = freeVars t
-freeVars (TFork l r) = freeVars l <> freeVars r
-freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
-
-isFree :: String -> TricuAST -> Bool
-isFree x = Set.member x . freeVars
-
--- We need the SKI operators in an unevaluated TricuAST tree form so that we
--- can keep the evaluation functions straightforward
-tI :: TricuAST
-tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
+elimLambda :: TricuAST -> TricuAST
+elimLambda = go
+ where
+ go (SLambda (v:vs) body)
+ | null vs = toSKI v (elimLambda body)
+ | otherwise = elimLambda (SLambda [v] (SLambda vs body))
+ go (SApp f g ) = SApp (elimLambda f) (elimLambda g)
+ go (TStem t ) = TStem (elimLambda t)
+ go (TFork l r ) = TFork (elimLambda l) (elimLambda r)
+ go (SList x ) = SList (map elimLambda x)
+ go x = x
-tK :: TricuAST
-tK = SApp TLeaf TLeaf
+ toSKI x (SVar y)
+ | x == y = _I
+ | otherwise = SApp _K (SVar y)
+ toSKI x t@(SApp n u)
+ | not (isFree x t) = SApp _K (SApp (elimLambda n) (elimLambda u))
+ | otherwise = SApp (SApp _S (toSKI x (elimLambda n))) (toSKI x (elimLambda u))
+ toSKI x t
+ | not (isFree x t) = SApp _K t
+ | otherwise = SApp (SApp _S (toSKI x t)) TLeaf
-tS :: TricuAST
-tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf
+ _S = parseSingle "t (t (t t t)) t"
+ _K = parseSingle "t t"
+ _I = parseSingle "t (t (t t)) t"
+
+ isFree x = Set.member x . freeVars
+ freeVars (SVar v ) = Set.singleton v
+ freeVars (SInt _ ) = Set.empty
+ freeVars (SStr _ ) = Set.empty
+ freeVars (SList s ) = foldMap freeVars s
+ freeVars (SApp f a ) = freeVars f <> freeVars a
+ freeVars (TLeaf ) = Set.empty
+ freeVars (SFunc _ _ b) = freeVars b
+ freeVars (TStem t ) = freeVars t
+ freeVars (TFork l r ) = freeVars l <> freeVars r
+ freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
-result :: Map String T -> T
+result :: Env -> T
result r = case Map.lookup "__result" r of
Just a -> a
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -17,18 +17,20 @@ type AltParser = Parsec Void String
parseTricu :: String -> [TricuAST]
parseTricu input
| null tokens = []
- | otherwise = map parseSingle tokens
+ | otherwise = map parseSingle tokens
where
- tokens = case lexTricu input of
- [] -> []
- tokens -> lines input
+ tokens
+ | null (lexTricu input) = []
+ | otherwise = lines input
parseSingle :: String -> TricuAST
-parseSingle input = case lexTricu input of
- [] -> SEmpty
- tokens -> case runParser parseExpression "" tokens of
- Left err -> error $ handleParseError err
- Right ast -> ast
+parseSingle input
+ | null tokens = SEmpty
+ | Left err <- parsed = error $ handleParseError err
+ | Right ast <- parsed = ast
+ where
+ tokens = lexTricu input
+ parsed = runParser parseExpression "" tokens
parseExpression :: Parser TricuAST
parseExpression = choice
@@ -115,10 +117,10 @@ parseTreeTerm = do
rest <- many parseTreeLeafOrParenthesized
pure $ foldl combine base rest
where
- combine acc next = case acc of
- TLeaf -> TStem next
- TStem t -> TFork t next
- TFork _ _ -> TFork acc next
+ combine acc next
+ | TLeaf <- acc = TStem next
+ | TStem t <- acc = TFork t next
+ | TFork _ _ <- acc = TFork acc next
parseTreeLeafOrParenthesized :: Parser TricuAST
parseTreeLeafOrParenthesized = choice
@@ -181,9 +183,9 @@ parseSingleItem :: Parser TricuAST
parseSingleItem = do
token <- satisfy isListItem
case token of
- LIdentifier name -> return (SVar name)
- LKeywordT -> return TLeaf
- _ -> fail "Unexpected token in list item"
+ _ | LIdentifier name <- token -> return (SVar name)
+ | LKeywordT <- token -> return TLeaf
+ | otherwise -> fail "Unexpected token in list item"
isListItem :: LToken -> Bool
isListItem (LIdentifier _) = True
@@ -254,9 +256,11 @@ parseTernaryFork = do
pure $ TFork term1 term2
parseTernary :: String -> Either String TricuAST
-parseTernary input = case runParser (parseTernaryTerm <* eof) "" input of
- Left err -> Left (errorBundlePretty err)
- Right ast -> Right ast
+parseTernary input
+ | Left err <- result = Left (errorBundlePretty err)
+ | Right ast <- result = Right ast
+ where
+ result = runParser (parseTernaryTerm <* eof) "" input
-- Error Handling
handleParseError :: ParseErrorBundle [LToken] Void -> String
diff --git a/src/REPL.hs b/src/REPL.hs
@@ -20,37 +20,36 @@ repl env = runInputT defaultSettings (loop env)
loop :: Env -> InputT IO ()
loop env = do
minput <- getInputLine "tricu < "
- case minput of
- Nothing -> outputStrLn "Exiting tricu"
- Just s -> case strip s of
- "!exit" -> outputStrLn "Exiting tricu"
- "!load" -> do
- path <- getInputLine "File path to load < "
- case path of
- Nothing -> do
- outputStrLn "No input received; stopping import."
- loop env
- Just path -> do
- loadedEnv <- liftIO $ evaluateFileWithContext env (strip path)
- loop $ Map.delete "__result" (Map.union loadedEnv env)
- "" -> do
- outputStrLn ""
- loop env
- input -> do
- case (take 2 input) of
- "--" -> loop env
- _ -> do
- newEnv <- liftIO $ (processInput env input `catch` errorHandler env)
- loop newEnv
-
+ if
+ | Nothing <- minput -> outputStrLn "Exiting tricu"
+ | Just s <- minput, strip s == "!exit" -> outputStrLn "Exiting tricu"
+ | Just s <- minput, strip s == "" -> do
+ outputStrLn ""
+ loop env
+ | Just s <- minput, strip s == "!load" -> do
+ path <- getInputLine "File path to load < "
+ if
+ | Nothing <- path -> do
+ outputStrLn "No input received; stopping import."
+ loop env
+ | Just p <- path -> do
+ loadedEnv <- liftIO $ evaluateFileWithContext env (strip p) `catch` \e -> errorHandler env e
+ loop $ Map.delete "__result" (Map.union loadedEnv env)
+ | Just s <- minput -> do
+ if
+ | take 2 s == "--" -> loop env
+ | otherwise -> do
+ newEnv <- liftIO $ processInput env s `catch` errorHandler env
+ loop newEnv
+
processInput :: Env -> String -> IO Env
processInput env input = do
- let asts = parseTricu input
+ let asts = parseTricu input
newEnv = evalTricu env asts
- case Map.lookup "__result" newEnv of
- Just r -> do
+ if
+ | Just r <- Map.lookup "__result" newEnv -> do
putStrLn $ "tricu > " ++ decodeResult r
- Nothing -> return ()
+ | otherwise -> return ()
return newEnv
errorHandler :: Env -> SomeException -> IO (Env)
@@ -62,10 +61,8 @@ repl env = runInputT defaultSettings (loop env)
strip = dropWhileEnd isSpace . dropWhile isSpace
decodeResult :: T -> String
-decodeResult tc = case toNumber tc of
- Right num -> show num
- Left _ -> case toString tc of
- Right str -> "\"" ++ str ++ "\""
- Left _ -> case toList tc of
- Right list -> "[" ++ intercalate ", " (map decodeResult list) ++ "]"
- Left _ -> formatResult TreeCalculus tc
+decodeResult tc
+ | Right num <- toNumber tc = show num
+ | Right str <- toString tc = "\"" ++ str ++ "\""
+ | Right list <- toList tc = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
+ | otherwise = formatResult TreeCalculus tc
diff --git a/src/Research.hs b/src/Research.hs
@@ -28,7 +28,7 @@ data TricuAST
| SEmpty
deriving (Show, Eq, Ord)
--- Tokens from Lexer
+-- Lexer Tokens
data LToken
= LKeywordT
| LIdentifier String
@@ -61,19 +61,6 @@ apply (Fork (Fork a1 a2) a3) Leaf = a1
apply (Fork (Fork a1 a2) a3) (Stem u) = apply a2 u
apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v
--- SKI Combinators
-_S :: T
-_S = Fork (Stem (Fork Leaf Leaf)) Leaf
-
-_K :: T
-_K = Stem Leaf
-
--- Identity
--- We use the "point-free" style which drops a redundant node
--- Full I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
-_I :: T
-_I = Fork (Stem (Stem Leaf)) Leaf
-
-- Booleans
_false :: T
_false = Leaf
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -31,7 +31,6 @@ tests = testGroup "Tricu Tests"
, lambdaEvalTests
, libraryTests
, fileEvaluationTests
- , propertyTests
]
lexerTests :: TestTree
@@ -414,13 +413,3 @@ fileEvaluationTests = testGroup "Evaluation tests"
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
decodeResult (result res) @?= "\"String test!\""
]
-
-propertyTests :: TestTree
-propertyTests = testGroup "Property Tests"
- [ testProperty "Lexing and parsing round-trip" $ \input ->
- case runParser tricuLexer "" input of
- Left _ -> property True
- Right tokens -> case runParser parseExpression "" tokens of
- Left _ -> property True
- Right ast -> parseSingle input === ast
- ]
diff --git a/tricu.cabal b/tricu.cabal
@@ -18,6 +18,7 @@ executable tricu
src
default-extensions:
DeriveDataTypeable
+ MultiWayIf
OverloadedStrings
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
build-depends:
@@ -43,6 +44,7 @@ test-suite tricu-tests
hs-source-dirs: test, src
default-extensions:
DeriveDataTypeable
+ MultiWayIf
OverloadedStrings
build-depends:
base
