diff --git a/src/Compiler.hs b/src/Compiler.hs index 87c5a5a..8906306 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -1,6 +1,7 @@ module Compiler where import Eval +import Library import Parser import Research @@ -11,13 +12,8 @@ import qualified Data.Map as Map evaluateFile :: FilePath -> IO T evaluateFile filePath = do contents <- readFile filePath - let linesOfFile = lines contents - let env = foldl evaluateLine Map.empty linesOfFile - case Map.lookup "__result" env of + let asts = parseTricu contents + let finalEnv = evalTricu library asts + case Map.lookup "__result" finalEnv of Just finalResult -> return finalResult Nothing -> error "No result found in final environment" - -evaluateLine :: Env -> String -> Env -evaluateLine env line = - let ast = parseSingle line - in evalSingle env ast diff --git a/src/Eval.hs b/src/Eval.hs index f837b3b..c670731 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -30,33 +30,36 @@ evalSingle env term = case term of in Map.insert "__result" result env evalTricu :: Map String T -> [TricuAST] -> Map String T -evalTricu env [] = env -evalTricu env [lastLine] = +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) = + evalTricu' env (line:rest) = let lineNoLambda = eliminateLambda line updatedEnv = evalSingle env lineNoLambda in evalTricu updatedEnv rest evalAST :: Map String T -> TricuAST -> T evalAST env term = case term of - SVar name -> case Map.lookup name env of - Just value -> value - Nothing -> error $ "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 Map.empty) elems) - SEmpty -> Leaf - SFunc name args body -> - error $ "Unexpected function definition " ++ name - ++ " in evalAST; define via evalSingle." - SLambda {} -> error "Internal error: SLambda found in evalAST after elimination." + SVar name -> case Map.lookup name env of + Just value -> value + Nothing -> error $ "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 Map.empty) elems) + SEmpty -> Leaf + SFunc name args body -> + error $ "Unexpected function definition " ++ name + ++ " in evalAST; define via evalSingle." + SLambda {} -> error "Internal error: SLambda found in evalAST after elimination." eliminateLambda :: TricuAST -> TricuAST eliminateLambda (SLambda (v:vs) body) @@ -117,5 +120,5 @@ tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf result :: Map String T -> T result r = case Map.lookup "__result" r of - Just a -> a - Nothing -> error "No __result field found in provided environment" + Just a -> a + Nothing -> error "No __result field found in provided environment" diff --git a/src/Lexer.hs b/src/Lexer.hs index 2e2303d..6d65c2e 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -104,7 +104,6 @@ tricuLexer = do , closeBracket ] - lexTricu :: String -> [LToken] lexTricu input = case runParser tricuLexer "" input of Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err diff --git a/src/Library.hs b/src/Library.hs index c4c9ddc..3ae1e23 100644 --- a/src/Library.hs +++ b/src/Library.hs @@ -37,7 +37,7 @@ library = evalTricu Map.empty $ parseTricu $ unlines , "emptyList = matchList true (\\y z : false)" , "head = matchList t (\\hd tl : hd)" , "tail = matchList t (\\hd tl : tl)" - , "listConcat = y (\\self : matchList (\\k : k) (\\h r k : pair h (self r k)))" + , "lconcat = y (\\self : matchList (\\k : k) (\\h r k : pair h (self r k)))" , "lAnd = triage (\\x : false) (\\_ x : x) (\\_ _ x : x)" , "lOr = triage (\\x : x) (\\_ _ : true) (\\_ _ x : true)" , "hmap = y (\\self : matchList (\\f : t) (\\hd tl f : pair (f hd) (self tl f)))" diff --git a/src/Main.hs b/src/Main.hs index 54eecf7..954751f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,11 @@ module Main where import Compiler -import Eval (evalTricu, result) +import Eval (evalTricu, result, toAST) import Library (library) import Parser (parseTricu) -import REPL (repl) -import Research (T) +import REPL +import Research import Text.Megaparsec (runParser) import System.Console.CmdArgs @@ -14,7 +14,11 @@ import qualified Data.Map as Map data TricuArgs = Repl - | Compile { file :: FilePath } + | Compile { file :: FilePath, output :: Maybe FilePath, form :: CompiledForm } + | Decode { input :: Maybe FilePath } + deriving (Show, Data, Typeable) + +data CompiledForm = TreeCalculus | AST | Ternary | Ascii deriving (Show, Data, Typeable) replMode :: TricuArgs @@ -24,14 +28,31 @@ replMode = Repl &= name "repl" compileMode :: TricuArgs -compileMode = Compile { file = def &= typ "FILE" &= help "Relative or absolute path to compile" } +compileMode = Compile + { file = def &= typ "FILE" + &= help "Relative or absolute path to file input for compilation" &= name "f" + , output = def &= typ "OUTPUT" + &= help "Optional output file path for resulting output" &= name "o" + , form = TreeCalculus &= typ "FORM" + &= help "Output form: (tree|ast|ternary|ascii)" + &= name "t" + } &= help "Compile a file and return the result of the expression in the final line" &= explicit &= name "compile" +decodeMode :: TricuArgs +decodeMode = Decode + { input = def &= typ "FILE" + &= help "Optional file path containing a Tree Calculus value. Defaults to stdin." &= name "f" + } + &= help "Decode a Tree Calculus value into a string representation" + &= explicit + &= name "decode" + main :: IO () main = do - args <- cmdArgs $ modes [replMode, compileMode] + args <- cmdArgs $ modes [replMode, compileMode, decodeMode] &= help "tricu: Exploring Tree Calculus" &= program "tricu" &= summary "tricu - compiler and repl" @@ -40,8 +61,23 @@ main = do Repl -> do putStrLn "Welcome to the tricu REPL" putStrLn "You can exit with `CTRL+D` or the `:_exit` command.`" - repl Map.empty - Compile filePath -> do + repl library + Compile { file = filePath, output = maybeOutputPath, form = form } -> do result <- evaluateFile filePath - print result + let fRes = formatResult form result + case maybeOutputPath of + Just outputPath -> do + writeFile outputPath fRes + putStrLn $ "Output to: " ++ outputPath + Nothing -> putStr fRes + Decode { input = maybeInputPath } -> do + value <- case maybeInputPath of + Just inputPath -> readFile inputPath + Nothing -> getContents + putStrLn $ decodeResult $ result $ evalTricu library $ parseTricu value +formatResult :: CompiledForm -> T -> String +formatResult TreeCalculus = show +formatResult AST = show . toAST +formatResult Ternary = toTernaryString +formatResult Ascii = toAscii diff --git a/src/Parser.hs b/src/Parser.hs index beb157b..2cffd7b 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -11,7 +11,8 @@ import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle) import qualified Data.Set as Set -type Parser = Parsec Void [LToken] +type Parser = Parsec Void [LToken] +type AltParser = Parsec Void String data TricuAST = SVar String @@ -242,6 +243,42 @@ isLiteral _ = False isNewline (LNewline) = True isNewline _ = False +-- Alternative parsers +altSC :: AltParser () +altSC = skipMany (char ' ' <|> char '\t' <|> char '\n') + +parseTernaryTerm :: AltParser TricuAST +parseTernaryTerm = do + altSC + term <- choice parseTernaryTerm' + altSC + pure term + where + parseTernaryTerm' = + [ try (between (char '(') (char ')') parseTernaryTerm) + , try parseTernaryLeaf + , try parseTernaryStem + , try parseTernaryFork + ] + +parseTernaryLeaf :: AltParser TricuAST +parseTernaryLeaf = char '0' *> pure TLeaf + +parseTernaryStem :: AltParser TricuAST +parseTernaryStem = char '1' *> (TStem <$> parseTernaryTerm) + +parseTernaryFork :: AltParser TricuAST +parseTernaryFork = do + char '2' + term1 <- parseTernaryTerm + term2 <- parseTernaryTerm + 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 + -- Error Handling handleParseError :: ParseErrorBundle [LToken] Void -> String handleParseError bundle = @@ -259,4 +296,3 @@ showError (FancyError offset fancy) = showError (TrivialError offset Nothing expected) = "Parse error at offset " ++ show offset ++ ": expected one of " ++ show (Set.toList expected) - diff --git a/src/REPL.hs b/src/REPL.hs index 76edcd6..d407e86 100644 --- a/src/REPL.hs +++ b/src/REPL.hs @@ -27,18 +27,18 @@ repl env = runInputT defaultSettings (loop env) Just input -> do newEnv <- liftIO $ (processInput env input `catch` errorHandler env) loop newEnv - - processInput :: Env -> String -> IO (Env) + + processInput :: Env -> String -> IO Env processInput env input = do - let clearEnv = Map.delete "__result" env - newEnv = evalSingle clearEnv (parseSingle input) + let asts = parseTricu input + newEnv = evalTricu env asts case Map.lookup "__result" newEnv of Just r -> do putStrLn $ "tricu > " ++ show r putStrLn $ "READ -: \"" ++ decodeResult r ++ "\"" Nothing -> return () return newEnv - + errorHandler :: Env -> SomeException -> IO (Env) errorHandler env e = do putStrLn $ "Error: " ++ show e diff --git a/src/Research.hs b/src/Research.hs index 0b59f1d..4a9e145 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -18,16 +18,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 -reduce :: T -> T -reduce expr = - let next = step expr - in if next == expr then expr else reduce next - -step :: T -> T -step (Fork left right) = reduce (apply (reduce left) (reduce right)) -step (Stem inner) = Stem (reduce inner) -step t = t - -- SKI Combinators _S :: T _S = Fork (Stem (Fork Leaf Leaf)) Leaf @@ -88,6 +78,12 @@ toList (Fork x rest) = case toList rest of Left err -> Left err toList _ = Left "Invalid Tree Calculus list" +-- Outputs +toTernaryString :: T -> String +toTernaryString Leaf = "0" +toTernaryString (Stem t) = "1" ++ toTernaryString t +toTernaryString (Fork t1 t2) = "2" ++ toTernaryString t1 ++ toTernaryString t2 + -- Utility type Env = Map.Map String T diff --git a/test.tri b/test.tri deleted file mode 100644 index 7ec7d67..0000000 --- a/test.tri +++ /dev/null @@ -1,2 +0,0 @@ -x = t t t -x diff --git a/test/Spec.hs b/test/Spec.hs index 8587f76..64a2160 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,12 +1,15 @@ module Main where +import Compiler import Eval import Lexer import Library import Parser import REPL import Research + import Control.Exception (evaluate, try, SomeException) +import Control.Monad.IO.Class (liftIO) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -28,6 +31,7 @@ tests = testGroup "Tricu Tests" , evaluationTests , lambdaEvalTests , libraryTests + , compilerTests , propertyTests ] @@ -213,7 +217,7 @@ evaluationTests = testGroup "Evaluation Tests" let input = "x = t t\nx = t\nx" env = evalTricu Map.empty (parseTricu input) (result env) @?= Leaf - , testCase "Apply identity to Boolean Not" $ do + , testCase "Apply identity to Boolean Not" $ do let not = "(t (t (t t) (t t t)) t)" let input = "x = (\\a : a)\nx " ++ not env = evalTricu Map.empty (parseTricu input) @@ -364,7 +368,7 @@ libraryTests = testGroup "Library Tests" env = evalTricu library (parseTricu input) result env @?= Stem Leaf , testCase "Concatenate strings" $ do - let input = "listConcat \"Hello, \" \"world!\"" + let input = "lconcat \"Hello, \" \"world!\"" env = decodeResult $ result $ evalTricu library (parseTricu input) env @?= "Hello, world!" , testCase "Verifying Equality" $ do @@ -373,6 +377,19 @@ libraryTests = testGroup "Library Tests" result env @?= Stem Leaf ] +compilerTests :: TestTree +compilerTests = testGroup "Compiler tests" + [ testCase "Forks" $ do + res <- liftIO $ evaluateFile "./test/fork.tri" + res @?= Fork Leaf Leaf + , testCase "File ends with comment" $ do + res <- liftIO $ evaluateFile "./test/comments-1.tri" + res @?= Fork (Stem Leaf) Leaf + , testCase "Mapping and Equality" $ do + res <- liftIO $ evaluateFile "./test/map.tri" + res @?= Stem Leaf + ] + propertyTests :: TestTree propertyTests = testGroup "Property Tests" [ testProperty "Lexing and parsing round-trip" $ \input -> diff --git a/test/ascii.tri b/test/ascii.tri new file mode 100644 index 0000000..ba749a9 --- /dev/null +++ b/test/ascii.tri @@ -0,0 +1 @@ +t (t (t (t (t t) (t t t)) t) t t) t diff --git a/test/comments-1.tri b/test/comments-1.tri new file mode 100644 index 0000000..ee8de08 --- /dev/null +++ b/test/comments-1.tri @@ -0,0 +1,9 @@ +-- This is a tricu comment! +-- t (t t) (t (t t t)) +-- t (t t t) (t t) +-- x = (\a : a) +t (t t) t -- Fork (Stem Leaf) Leaf +-- t t +-- x +-- x = (\a : a) +-- t diff --git a/test/fork.tri b/test/fork.tri new file mode 100644 index 0000000..66c0658 --- /dev/null +++ b/test/fork.tri @@ -0,0 +1 @@ +t t t diff --git a/test/map.tri b/test/map.tri new file mode 100644 index 0000000..f8c8f7a --- /dev/null +++ b/test/map.tri @@ -0,0 +1,24 @@ +false = t +true = t t +_ = t +k = t t +i = t (t k) t +s = t (t (k t)) t +m = s i i +b = s (k s) k +c = s (s (k s) (s (k k) s)) (k k) +iC = (\a b c : s a (k c) b) +yi = (\i : b m (c b (i m))) +y = yi iC +triage = (\a b c : t (t a b) c) +pair = t +matchList = (\oe oc : triage oe _ oc) +lconcat = y (\self : matchList (\k : k) (\h r k : pair h (self r k))) +hmap = y (\self : matchList (\f : t) (\hd tl f : pair (f hd) (self tl f))) +map = (\f l : hmap l f) +lAnd = triage (\x : false) (\_ x : x) (\_ _ x : x) +lOr = triage (\x : x) (\_ _ : true) (\_ _ x : true) +equal = y (\self : triage (triage true (\z : false) (\y z : false)) (\ax : triage false (self ax) (\y z : false)) (\ax ay : triage false (\z : false) (\bx by : lAnd (self ax bx) (self ay by)))) + +x = map (\i : lconcat "Successfully concatenated " i) [("two strings!")] +equal x [("Successfully concatenated two strings!")]