From ad02c8b86aaaf0344f3f9a5825f165388b764d8b Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sun, 19 Jan 2025 14:41:25 -0600 Subject: [PATCH] General refactor for legibility Priming to update all source to lhs and document extensively --- src/Eval.hs | 163 +++++++++++++++++++++--------------------------- src/Parser.hs | 42 +++++++------ src/REPL.hs | 65 +++++++++---------- src/Research.hs | 15 +---- test/Spec.hs | 11 ---- tricu.cabal | 2 + 6 files changed, 127 insertions(+), 171 deletions(-) diff --git a/src/Eval.hs b/src/Eval.hs index 0aa1d6b..468b70f 100644 --- 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 +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 -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 + 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 -isFree :: String -> TricuAST -> Bool -isFree x = Set.member x . freeVars + _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 --- 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 - -tK :: TricuAST -tK = SApp TLeaf TLeaf - -tS :: TricuAST -tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf - -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 index 28ec38b..87e7fae 100644 --- 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 index 44a6081..407b423 100644 --- 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 index e22071a..8638cdb 100644 --- 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 index 1fa8fd5..666f04b 100644 --- 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 index 0247a45..117ddea 100644 --- 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