diff --git a/.gitignore b/.gitignore index 15fe151..e8c3ecb 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ WD bin/ dist* +.tricu_history diff --git a/flake.nix b/flake.nix index e5bbfc6..0667747 100644 --- a/flake.nix +++ b/flake.nix @@ -34,6 +34,7 @@ devShells.default = pkgs.mkShell { buildInputs = with pkgs; [ haskellPackages.cabal-install + haskellPackages.ghc-events haskellPackages.ghcid customGHC upx diff --git a/lib/base.tri b/lib/base.tri index 914bfe7..1dbc0ef 100644 --- a/lib/base.tri +++ b/lib/base.tri @@ -31,7 +31,7 @@ lOr = (triage (\_ _ : true) (\_ _ _ : true)) -matchPair = \a : triage _ _ a +matchPair = \a : triage _ _ a not? = matchBool false true and? = matchBool id (\_ : false) diff --git a/lib/patterns.tri b/lib/patterns.tri new file mode 100644 index 0000000..68dc822 --- /dev/null +++ b/lib/patterns.tri @@ -0,0 +1,35 @@ +!import "list.tri" !Local + +match_ = y (\self value patterns : + triage + t + (\_ : t) + (\pattern rest : + triage + t + (\_ : t) + (\test result : + if (test value) + (result value) + (self value rest)) + pattern) + patterns) + +match = (\value patterns : + match_ value (map (\sublist : + pair (head sublist) (head (tail sublist))) + patterns)) + +otherwise = const (t t) + +-- matchExample = (\x : match x [[(equal? 1) (\_ : "one")] +-- [(equal? 2) (\_ : "two")] +-- [(equal? 3) (\_ : "three")] +-- [(equal? 4) (\_ : "four")] +-- [(equal? 5) (\_ : "five")] +-- [(equal? 6) (\_ : "six")] +-- [(equal? 7) (\_ : "seven")] +-- [(equal? 8) (\_ : "eight")] +-- [(equal? 9) (\_ : "nine")] +-- [(equal? 10) (\_ : "ten")] +-- [ otherwise (\_ : "I ran out of fingers!")]]) diff --git a/src/Eval.hs b/src/Eval.hs index 832c351..46b077b 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -19,16 +19,16 @@ evalSingle env term Nothing -> let res = evalAST env body in Map.insert "!result" res (Map.insert name res env) - | SApp func arg <- term + | SApp func arg <- term = let res = apply (evalAST env func) (evalAST env arg) in Map.insert "!result" res env - | SVar name <- term + | SVar name <- term = case Map.lookup name env of Just v -> Map.insert "!result" v env Nothing -> errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined\n\ \This error should never occur here. Please report this as an issue." - | otherwise + | otherwise = Map.insert "!result" (evalAST env term) env evalTricu :: Env -> [TricuAST] -> Env diff --git a/src/FileEval.hs b/src/FileEval.hs index 5b9845f..50dd8b8 100644 --- a/src/FileEval.hs +++ b/src/FileEval.hs @@ -6,6 +6,7 @@ import Parser import Research import Data.List (partition) +import Data.Maybe (mapMaybe) import Control.Monad (foldM) import System.IO import System.FilePath (takeDirectory, normalise, ()) @@ -13,6 +14,26 @@ import System.FilePath (takeDirectory, normalise, ()) import qualified Data.Map as Map import qualified Data.Set as Set +extractMain :: Env -> Either String T +extractMain env = + case Map.lookup "main" env of + Just result -> Right result + Nothing -> Left "No `main` function detected" + +processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST] + -> Either String ([TricuAST], [(FilePath, String, FilePath)]) +processImports seen base currentPath asts = + let (imports, nonImports) = partition isImp asts + importPaths = mapMaybe getImportInfo imports + in if currentPath `Set.member` seen + then Left $ "Encountered cyclic import: " ++ currentPath + else Right (nonImports, importPaths) + where + isImp (SImport _ _) = True + isImp _ = False + getImportInfo (SImport p n) = Just (p, n, makeRelativeTo currentPath p) + getImportInfo _ = Nothing + evaluateFileResult :: FilePath -> IO T evaluateFileResult filePath = do contents <- readFile filePath @@ -20,11 +41,11 @@ evaluateFileResult filePath = do case parseProgram tokens of Left err -> errorWithoutStackTrace (handleParseError err) Right ast -> do - ast <- preprocessFile filePath - let finalEnv = evalTricu Map.empty ast - case Map.lookup "main" finalEnv of - Just finalResult -> return finalResult - Nothing -> errorWithoutStackTrace "No `main` function detected" + processedAst <- preprocessFile filePath + let finalEnv = evalTricu Map.empty processedAst + case extractMain finalEnv of + Right result -> return result + Left err -> errorWithoutStackTrace err evaluateFile :: FilePath -> IO Env evaluateFile filePath = do @@ -50,37 +71,25 @@ preprocessFile :: FilePath -> IO [TricuAST] preprocessFile p = preprocessFile' Set.empty p p preprocessFile' :: Set.Set FilePath -> FilePath -> FilePath -> IO [TricuAST] -preprocessFile' s b p - | p `Set.member` s = - errorWithoutStackTrace $ "Encountered cyclic import: " ++ p - | otherwise = do - c <- readFile p - let t = lexTricu c - case parseProgram t of - Left e -> errorWithoutStackTrace (handleParseError e) - Right a -> do - let (i, n) = partition isImp a - let s' = Set.insert p s - r <- concat <$> - mapM (procImp s' "" p) i - pure $ r ++ n +preprocessFile' seen base currentPath = do + contents <- readFile currentPath + let tokens = lexTricu contents + case parseProgram tokens of + Left err -> errorWithoutStackTrace (handleParseError err) + Right ast -> + case processImports seen base currentPath ast of + Left err -> errorWithoutStackTrace err + Right (nonImports, importPaths) -> do + let seen' = Set.insert currentPath seen + imported <- concat <$> mapM (processImportPath seen' base) importPaths + pure $ imported ++ nonImports where - isImp :: TricuAST -> Bool + processImportPath seen base (path, name, importPath) = do + ast <- preprocessFile' seen base importPath + pure $ map (nsDefinition (if name == "!Local" then "" else name)) + $ filter (not . isImp) ast isImp (SImport _ _) = True - isImp _ = False - - procImp :: Set.Set FilePath -> String -> FilePath -> TricuAST -> IO [TricuAST] - procImp s m f (SImport p "!Local") = do - let ip = makeRelativeTo f p - a <- preprocessFile' s b ip - let d = filter (not . isImp) a - pure $ map (nsDefinition m) d - procImp s _ f (SImport p n) = do - let ip = makeRelativeTo f p - a <- preprocessFile' s b ip - let d = filter (not . isImp) a - pure $ map (nsDefinition n) d - procImp _ _ _ _ = error "Unexpected non-import in processImport" + isImp _ = False makeRelativeTo :: FilePath -> FilePath -> FilePath makeRelativeTo f i = @@ -94,7 +103,7 @@ nsDefinition :: String -> TricuAST -> TricuAST nsDefinition "" def = def nsDefinition moduleName (SDef name args body) | isPrefixed name = SDef name args (nsBody moduleName body) - | otherwise = SDef (nsVariable moduleName name) + | otherwise = SDef (nsVariable moduleName name) args (nsBody moduleName body) nsDefinition moduleName other = nsBody moduleName other @@ -115,7 +124,7 @@ nsBody moduleName (TStem subtree) = TStem (nsBody moduleName subtree) nsBody moduleName (SDef name args body) | isPrefixed name = SDef name args (nsBody moduleName body) - | otherwise = SDef (nsVariable moduleName name) + | otherwise = SDef (nsVariable moduleName name) args (nsBody moduleName body) nsBody _ other = other @@ -125,19 +134,19 @@ nsBodyScoped moduleName args body = case body of if name `elem` args then SVar name else nsBody moduleName (SVar name) - SApp func arg -> + SApp func arg -> SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg) - SLambda innerArgs innerBody -> + SLambda innerArgs innerBody -> SLambda innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody) - SList items -> + SList items -> SList (map (nsBodyScoped moduleName args) items) - TFork left right -> - TFork (nsBodyScoped moduleName args left) + TFork left right -> + TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right) - TStem subtree -> + TStem subtree -> TStem (nsBodyScoped moduleName args subtree) SDef name innerArgs innerBody -> - SDef (nsVariable moduleName name) innerArgs + SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody) other -> other diff --git a/src/Lexer.hs b/src/Lexer.hs index f881d6f..53426d4 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -59,7 +59,7 @@ keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT identifier :: Lexer LToken identifier = do first <- lowerChar <|> char '_' - rest <- many $ letterChar + rest <- many $ letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' <|> char '$' <|> char '#' <|> char '@' <|> char '%' let name = first : rest diff --git a/src/Parser.hs b/src/Parser.hs index 20828a6..5643490 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -255,9 +255,9 @@ parseSingleItemM = do parseVarM :: ParserM TricuAST parseVarM = do - token <- satisfyM (\case + token <- satisfyM (\case LNamespace _ -> True - LIdentifier _ -> True + LIdentifier _ -> True _ -> False) case token of LNamespace ns -> do diff --git a/src/REPL.hs b/src/REPL.hs index db50b90..9a83d9a 100644 --- a/src/REPL.hs +++ b/src/REPL.hs @@ -6,21 +6,35 @@ import Lexer import Parser import Research -import Control.Exception (SomeException, catch) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Catch (handle, MonadCatch) -import Data.Char (isSpace) -import Data.List ( dropWhile - , dropWhileEnd - , intercalate - , isPrefixOf) +import Control.Exception (SomeException, catch) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Catch (handle, MonadCatch) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.Char (isSpace) +import Data.List ( dropWhile + , dropWhileEnd + , isPrefixOf) import System.Console.Haskeline import qualified Data.Map as Map repl :: Env -> IO () -repl env = runInputT defaultSettings (withInterrupt (loop env True)) +repl env = runInputT settings (withInterrupt (loop env True)) where + settings :: Settings IO + settings = Settings + { complete = completeWord Nothing " \t" completeCommands + , historyFile = Just ".tricu_history" + , autoAddHistory = True + } + + completeCommands :: String -> IO [Completion] + completeCommands str = return $ map simpleCompletion $ + filter (str `isPrefixOf`) commands + where + commands = ["!exit", "!decode", "!definitions", "!import"] + loop :: Env -> Bool -> InputT IO () loop env decode = handle (interruptHandler env decode) $ do minput <- getInputLine "tricu < " @@ -32,26 +46,48 @@ repl env = runInputT defaultSettings (withInterrupt (loop env True)) | strip s == "!decode" -> do outputStrLn $ "Decoding " ++ (if decode then "disabled" else "enabled") loop env (not decode) - | "!import" `isPrefixOf` strip s -> do - let afterImport = dropWhile (== ' ') $ drop (length ("!import" :: String)) (strip s) - if not (null afterImport) - then outputStrLn "Warning: REPL imports are interactive; \ - \additional arguments are ignored." - else pure () - path <- getInputLine "File path to load < " - case path of - Nothing -> do - outputStrLn "No input received; stopping import." - loop env decode - Just p -> do - loadedEnv <- liftIO $ evaluateFileWithContext env - (strip p) `catch` \e -> errorHandler env e - loop (Map.delete "!result" (Map.union loadedEnv env)) decode + | strip s == "!definitions" -> do + let defs = Map.keys $ Map.delete "!result" env + if null defs + then outputStrLn "No definitions discovered." + else do + outputStrLn "Available definitions:" + mapM_ outputStrLn defs + loop env decode + | "!import" `isPrefixOf` strip s -> handleImport env decode | take 2 s == "--" -> loop env decode | otherwise -> do newEnv <- liftIO $ processInput env s decode `catch` errorHandler env loop newEnv decode + handleImport :: Env -> Bool -> InputT IO () + handleImport env decode = do + result <- runMaybeT $ do + let fileSettings = setComplete completeFilename defaultSettings + path <- MaybeT $ runInputT fileSettings $ + getInputLineWithInitial "File path to load < " ("", "") + + contents <- liftIO $ readFile (strip path) + + if | Left err <- parseProgram (lexTricu contents) -> do + lift $ outputStrLn $ "Parse error: " ++ handleParseError err + MaybeT $ return Nothing + | Right ast <- parseProgram (lexTricu contents) -> do + ns <- MaybeT $ runInputT defaultSettings $ + getInputLineWithInitial "Namespace (or !Local for no namespace) < " ("", "") + + processedAst <- liftIO $ preprocessFile (strip path) + let namespacedAst | strip ns == "!Local" = processedAst + | otherwise = nsDefinitions (strip ns) processedAst + loadedEnv = evalTricu env namespacedAst + return loadedEnv + + if | Nothing <- result -> do + outputStrLn "Import cancelled." + loop env decode + | Just loadedEnv <- result -> + loop (Map.delete "!result" loadedEnv) decode + interruptHandler :: Env -> Bool -> Interrupt -> InputT IO () interruptHandler env decode _ = do outputStrLn "Interrupted with CTRL+C\n\ @@ -64,17 +100,17 @@ repl env = runInputT defaultSettings (withInterrupt (loop env True)) newEnv = evalTricu env asts case Map.lookup "!result" newEnv of Just r -> do - putStrLn $ "tricu > " ++ - if decode + putStrLn $ "tricu > " ++ + if decode then decodeResult r else show r Nothing -> pure () return newEnv - + errorHandler :: Env -> SomeException -> IO (Env) errorHandler env e = do putStrLn $ "Error: " ++ show e return env - + strip :: String -> String strip = dropWhileEnd isSpace . dropWhile isSpace diff --git a/src/Research.hs b/src/Research.hs index e9ae6f7..ddec44a 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -53,7 +53,7 @@ data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode deriving (Show, Data, Typeable) -- Environment containing previously evaluated TC terms -type Env = Map.Map String T +type Env = Map.Map String T -- Tree Calculus Reduction apply :: T -> T -> T @@ -122,7 +122,7 @@ formatResult Ascii = toAscii formatResult Decode = decodeResult toSimpleT :: String -> String -toSimpleT s = T.unpack +toSimpleT s = T.unpack $ replace "Fork" "t" $ replace "Stem" "t" $ replace "Leaf" "t" diff --git a/tricu.cabal b/tricu.cabal index e0a4b21..983a817 100644 --- a/tricu.cabal +++ b/tricu.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: tricu -version: 0.14.0 +version: 0.15.0 description: A micro-language for exploring Tree Calculus author: James Eversole maintainer: james@eversole.co @@ -32,6 +32,7 @@ executable tricu , megaparsec , mtl , text + , transformers other-modules: Eval FileEval @@ -63,6 +64,7 @@ test-suite tricu-tests , tasty-hunit , tasty-quickcheck , text + , transformers default-language: Haskell2010 other-modules: Eval