Compare commits
	
		
			5 Commits
		
	
	
		
			main
			...
			contentsto
		
	
	| Author | SHA1 | Date | |
|---|---|---|---|
| 72e5810ca9 | |||
| b96a3f2ef0 | |||
| 6780b242b1 | |||
| 94514f7dd0 | |||
| 43e83be9a4 | 
							
								
								
									
										1
									
								
								.gitignore
									
									
									
									
										vendored
									
									
								
							
							
						
						
									
										1
									
								
								.gitignore
									
									
									
									
										vendored
									
									
								
							| @ -6,6 +6,7 @@ | ||||
| /Dockerfile | ||||
| /config.dhall | ||||
| /result | ||||
| .aider* | ||||
| WD | ||||
| bin/ | ||||
| dist* | ||||
|  | ||||
							
								
								
									
										44
									
								
								README.md
									
									
									
									
									
								
							
							
						
						
									
										44
									
								
								README.md
									
									
									
									
									
								
							| @ -14,6 +14,17 @@ Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-persona | ||||
|  | ||||
| [treecalcul.us](https://treecalcul.us) is an excellent website with an intuitive Tree Calculus code playground created by [Johannes Bader](https://johannes-bader.com/) that introduced me to Tree Calculus. | ||||
|  | ||||
| ## Features | ||||
|  | ||||
| - Tree Calculus **operator**: `t` | ||||
| - **Immutable definitions**: `x = t t` | ||||
| - **Lambda abstraction**: `id = (a : a)` | ||||
| - **List, Number, and String** literals: `[(2) ("Hello")]`  | ||||
| - **Function application**: `not (not false)` | ||||
| - **Higher order/first-class functions**: `map (a : append a "!") [("Hello")]` | ||||
| - **Intensionality** blurs the distinction between functions and data (see REPL examples) | ||||
| - **Content-addressed store**: save, version, tag, and recall your tricu terms. | ||||
|  | ||||
| ## REPL examples | ||||
|  | ||||
| ``` | ||||
| @ -36,17 +47,32 @@ tricu < -- or calculate its size (/demos/size.tri) | ||||
| tricu < size not? | ||||
| tricu > 12 | ||||
|  | ||||
| tricu < -- REPL Commands: | ||||
| tricu < !definitions  -- Lists all available definitions | ||||
| tricu < !output       -- Change output format (Tree, FSL, AST, etc.) | ||||
| tricu < !import       -- Import definitions from a file | ||||
| tricu < !exit         -- Exit the REPL | ||||
| tricu < !clear        -- ANSI screen clear | ||||
| tricu < !save         -- Save all REPL definitions to a file that you can !import | ||||
| tricu < !reset        -- Clear all REPL definitions | ||||
| tricu < !version      -- Print tricu version | ||||
| tricu < !help  | ||||
| tricu version 0.20.0 | ||||
| Available commands: | ||||
|     !exit        - Exit the REPL | ||||
|     !clear       - Clear the screen | ||||
|     !reset       - Reset preferences for selected versions | ||||
|     !help        - Show tricu version and available commands | ||||
|     !output      - Change output format (tree|fsl|ast|ternary|ascii|decode) | ||||
|     !definitions - List all defined terms in the content store | ||||
|     !import      - Import definitions from file (definitions are stored) | ||||
|     !watch       - Watch a file for changes (definitions are stored) | ||||
|     !versions    - Show all versions of a term by name | ||||
|     !select      - Select a specific version of a term for subsequent lookups | ||||
|     !tag         - Add or update a tag for a term by hash or name | ||||
| ``` | ||||
|  | ||||
| ## Content Store | ||||
|  | ||||
| tricu uses a "content store" SQLite database that saves and versions your definitions persistently. | ||||
|  | ||||
| *   **Persistent definitions:** Any term you define in the REPL is automatically saved. | ||||
| *   **Content-addressed:** Terms are stored based on a SHA256 hash of their content. This means identical terms are stored only once, even if they have different names. | ||||
| *   **Versioning and history:** If you redefine a name, the Content Store keeps a record of previous definitions associated with that name. You can explore the history of a term and access older versions. | ||||
| *   **Tagging:** You can assign tags to versions of your terms to organize and quickly switch between related function versions. | ||||
| *   **Querying:** The store allows you to search for terms by name, hash, or tags. | ||||
|  | ||||
| ## Installation and Use | ||||
|  | ||||
| You can easily build and run this project using [Nix](https://nixos.org/download/). | ||||
|  | ||||
| @ -1,5 +1,5 @@ | ||||
| !import "base.tri" !Local | ||||
| !import "list.tri" List | ||||
| !import "list.tri" !Local | ||||
|  | ||||
| match_ = y (self value patterns : | ||||
|   triage | ||||
| @ -17,8 +17,8 @@ match_ = y (self value patterns : | ||||
|     patterns) | ||||
|  | ||||
| match = (value patterns : | ||||
|   match_ value (List.map (sublist : | ||||
|     pair (List.head sublist) (List.head (List.tail sublist))) | ||||
|   match_ value (map (sublist : | ||||
|     pair (head sublist) (head (tail sublist))) | ||||
|     patterns)) | ||||
|  | ||||
| otherwise = const (t t) | ||||
|  | ||||
							
								
								
									
										230
									
								
								src/ContentStore.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										230
									
								
								src/ContentStore.hs
									
									
									
									
									
										Normal file
									
								
							| @ -0,0 +1,230 @@ | ||||
| module ContentStore where | ||||
|  | ||||
| import Research | ||||
| import Parser | ||||
|  | ||||
| import Control.Monad                  (foldM, forM) | ||||
| import Crypto.Hash                    (hash, SHA256, Digest) | ||||
| import Data.ByteString                (ByteString) | ||||
| import Data.List                      (intercalate, nub, sortBy, sort) | ||||
| import Data.Maybe                     (catMaybes) | ||||
| import Data.Text                      (Text) | ||||
| import Database.SQLite.Simple | ||||
| import Database.SQLite.Simple.FromRow (FromRow(..), field) | ||||
| import System.Directory               (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..)) | ||||
| import System.FilePath                ((</>), takeDirectory) | ||||
|  | ||||
| import qualified Data.ByteString      as BS | ||||
| import qualified Data.ByteString.Lazy as LBS | ||||
| import qualified Data.Map             as Map | ||||
| import qualified Data.Serialize       as Cereal | ||||
| import qualified Data.Text            as T | ||||
|  | ||||
| data StoredTerm = StoredTerm | ||||
|   { termHash :: Text | ||||
|   , termNames :: Text | ||||
|   , termData :: ByteString | ||||
|   , termMetadata :: Text | ||||
|   , termCreatedAt :: Integer | ||||
|   , termTags :: Text | ||||
|   } deriving (Show) | ||||
|  | ||||
| instance FromRow StoredTerm where | ||||
|   fromRow = StoredTerm <$> field <*> field <*> field <*> field <*> field <*> field | ||||
|  | ||||
| tryDeserializeTerm :: ByteString -> IO (Maybe T) | ||||
| tryDeserializeTerm bs = | ||||
|   case deserializeTerm bs of | ||||
|     Right t -> return $ Just t | ||||
|     Left err -> do | ||||
|       putStrLn $ "Error deserializing term: " ++ err | ||||
|       return Nothing | ||||
|  | ||||
| parseNameList :: Text -> [Text] | ||||
| parseNameList = filter (not . T.null) . T.splitOn "," | ||||
|  | ||||
| serializeNameList :: [Text] -> Text | ||||
| serializeNameList = T.intercalate "," . nub . sort | ||||
|  | ||||
| initContentStore :: IO Connection | ||||
| initContentStore = do | ||||
|   dbPath <- getContentStorePath | ||||
|   createDirectoryIfMissing True (takeDirectory dbPath) | ||||
|   conn <- open dbPath | ||||
|   execute_ conn "CREATE TABLE IF NOT EXISTS terms (\ | ||||
|                 \hash TEXT PRIMARY KEY, \ | ||||
|                 \names TEXT, \ | ||||
|                 \term_data BLOB, \ | ||||
|                 \metadata TEXT, \ | ||||
|                 \created_at INTEGER DEFAULT (strftime('%s','now')), \ | ||||
|                 \tags TEXT DEFAULT '')" | ||||
|   execute_ conn "CREATE INDEX IF NOT EXISTS terms_names_idx ON terms(names)" | ||||
|   execute_ conn "CREATE INDEX IF NOT EXISTS terms_tags_idx ON terms(tags)" | ||||
|   return   conn | ||||
|  | ||||
| getContentStorePath :: IO FilePath | ||||
| getContentStorePath = do | ||||
|   dataDir <- getXdgDirectory XdgData "tricu" | ||||
|   return $ dataDir </> "content-store.db" | ||||
|  | ||||
| instance Cereal.Serialize T where | ||||
|   put Leaf = Cereal.putWord8 0 | ||||
|   put (Stem t) = do | ||||
|     Cereal.putWord8 1 | ||||
|     Cereal.put t | ||||
|   put (Fork a b) = do | ||||
|     Cereal.putWord8 2 | ||||
|     Cereal.put a | ||||
|     Cereal.put b | ||||
|  | ||||
|   get = do | ||||
|     tag <- Cereal.getWord8 | ||||
|     case tag of | ||||
|       0 -> return Leaf | ||||
|       1 -> Stem <$> Cereal.get | ||||
|       2 -> Fork <$> Cereal.get <*> Cereal.get | ||||
|       _ -> fail $ "Invalid tag for T: " ++ show tag | ||||
|  | ||||
| serializeTerm :: T -> ByteString | ||||
| serializeTerm = LBS.toStrict . Cereal.encodeLazy | ||||
|  | ||||
| deserializeTerm :: ByteString -> Either String T | ||||
| deserializeTerm = Cereal.decodeLazy . LBS.fromStrict | ||||
|  | ||||
| hashTerm :: T -> Text | ||||
| hashTerm = T.pack . show . (hash :: ByteString -> Digest SHA256) . serializeTerm | ||||
|  | ||||
| storeTerm :: Connection -> [String] -> T -> IO Text | ||||
| storeTerm conn newNamesStrList term = do | ||||
|   let termBS = serializeTerm term | ||||
|       termHashText = hashTerm term | ||||
|       newNamesTextList = map T.pack newNamesStrList | ||||
|       metadataText = T.pack "{}" | ||||
|  | ||||
|   existingNamesQuery <- query conn | ||||
|     "SELECT names FROM terms WHERE hash = ?" | ||||
|     (Only termHashText) :: IO [Only Text] | ||||
|  | ||||
|   case existingNamesQuery of | ||||
|     [] -> do | ||||
|       let allNamesToStore = serializeNameList newNamesTextList | ||||
|       execute conn | ||||
|         "INSERT INTO terms (hash, names, term_data, metadata, tags) VALUES (?, ?, ?, ?, ?)" | ||||
|         (termHashText, allNamesToStore, termBS, metadataText, T.pack "") | ||||
|     [(Only currentNamesText)] -> do | ||||
|       let currentNamesList = parseNameList currentNamesText | ||||
|       let combinedNamesList = currentNamesList ++ newNamesTextList | ||||
|       let allNamesToStore = serializeNameList combinedNamesList | ||||
|       execute conn | ||||
|         "UPDATE terms SET names = ?, metadata = ? WHERE hash = ?" | ||||
|         (allNamesToStore, metadataText, termHashText) | ||||
|  | ||||
|   return termHashText | ||||
|  | ||||
| hashToTerm :: Connection -> Text -> IO (Maybe StoredTerm) | ||||
| hashToTerm conn hashText = | ||||
|   queryMaybeOne conn (selectStoredTermFields <> " WHERE hash = ?") (Only hashText) | ||||
|  | ||||
| nameToTerm :: Connection -> Text -> IO (Maybe StoredTerm) | ||||
| nameToTerm conn nameText = | ||||
|   queryMaybeOne conn | ||||
|     (selectStoredTermFields <> " WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC LIMIT 1") | ||||
|     (nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText) | ||||
|  | ||||
| listStoredTerms :: Connection -> IO [StoredTerm] | ||||
| listStoredTerms conn = | ||||
|   query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC") | ||||
|  | ||||
| storeEnvironment :: Connection -> Env -> IO [(String, Text)] | ||||
| storeEnvironment conn env = do | ||||
|   let defs = Map.toList $ Map.delete "!result" env | ||||
|   let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs] | ||||
|  | ||||
|   forM groupedDefs $ \(term, namesList) -> do | ||||
|     hashVal <- storeTerm conn namesList term | ||||
|     return (head namesList, hashVal) | ||||
|  | ||||
| loadTerm :: Connection -> String -> IO (Maybe T) | ||||
| loadTerm conn identifier = do | ||||
|   result <- getTerm conn (T.pack identifier) | ||||
|   case result of | ||||
|     Just storedTerm -> tryDeserializeTerm (termData storedTerm) | ||||
|     Nothing -> return Nothing | ||||
|  | ||||
| getTerm :: Connection -> Text -> IO (Maybe StoredTerm) | ||||
| getTerm conn identifier = do | ||||
|   if '#' `elem` (T.unpack identifier) | ||||
|     then hashToTerm conn (T.pack $ drop 1 (T.unpack identifier)) | ||||
|     else nameToTerm conn identifier | ||||
|  | ||||
| loadEnvironment :: Connection -> IO Env | ||||
| loadEnvironment conn = do | ||||
|   terms <- listStoredTerms conn | ||||
|   foldM addTermToEnv Map.empty terms | ||||
|   where | ||||
|     addTermToEnv env storedTerm = do | ||||
|       maybeT <- tryDeserializeTerm (termData storedTerm) | ||||
|       case maybeT of | ||||
|         Just t -> do | ||||
|           let namesList = parseNameList (termNames storedTerm) | ||||
|           return $ foldl (\e name -> Map.insert (T.unpack name) t e) env namesList | ||||
|         Nothing -> return env | ||||
|  | ||||
| termVersions :: Connection -> String -> IO [(Text, T, Integer)] | ||||
| termVersions conn name = do | ||||
|   let nameText = T.pack name | ||||
|   results <- query conn | ||||
|     ("SELECT hash, term_data, created_at FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC") | ||||
|     (nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText) | ||||
|  | ||||
|   catMaybes <$> mapM (\(hashVal, termDataVal, timestamp) -> do | ||||
|     maybeT <- tryDeserializeTerm termDataVal | ||||
|     return $ fmap (\t -> (hashVal, t, timestamp)) maybeT | ||||
|     ) results | ||||
|  | ||||
| setTag :: Connection -> Text -> Text -> IO () | ||||
| setTag conn hash tagValue = do | ||||
|   exists <- termExists conn hash | ||||
|   if exists | ||||
|     then do | ||||
|       currentTagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text] | ||||
|       case currentTagsQuery of | ||||
|         [Only tagsText] -> do | ||||
|           let tagsList = parseNameList tagsText | ||||
|               newTagsList = tagValue : tagsList | ||||
|               newTags = serializeNameList newTagsList | ||||
|           execute conn "UPDATE terms SET tags = ? WHERE hash = ?" (newTags, hash) | ||||
|         _ -> putStrLn $ "Term with hash " ++ T.unpack hash ++ " not found (should not happen if exists is true)" | ||||
|     else | ||||
|       putStrLn $ "Term with hash " ++ T.unpack hash ++ " does not exist" | ||||
|  | ||||
| termExists :: Connection -> Text -> IO Bool | ||||
| termExists conn hash = do | ||||
|   results <- query conn "SELECT 1 FROM terms WHERE hash = ? LIMIT 1" (Only hash) :: IO [[Int]] | ||||
|   return $ not (null results) | ||||
|  | ||||
| termToTags :: Connection -> Text -> IO [Text] | ||||
| termToTags conn hash = do | ||||
|   tagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text] | ||||
|   case tagsQuery of | ||||
|     [Only tagsText] -> return $ parseNameList tagsText | ||||
|     _ -> return [] | ||||
|  | ||||
| tagToTerm :: Connection -> Text -> IO [StoredTerm] | ||||
| tagToTerm conn tagValue = do | ||||
|   let pattern = "%" <> tagValue <> "%" | ||||
|   query conn (selectStoredTermFields <> " WHERE tags LIKE ? ORDER BY created_at DESC") (Only pattern) | ||||
|  | ||||
| allTermTags :: Connection -> IO [StoredTerm] | ||||
| allTermTags conn = do | ||||
|   query_ conn (selectStoredTermFields <> " WHERE tags IS NOT NULL AND tags != '' ORDER BY created_at DESC") | ||||
|  | ||||
| selectStoredTermFields :: Query | ||||
| selectStoredTermFields = "SELECT hash, names, term_data, metadata, created_at, tags FROM terms" | ||||
|  | ||||
| queryMaybeOne :: (FromRow r, ToRow q) => Connection -> Query -> q -> IO (Maybe r) | ||||
| queryMaybeOne conn qry params = do | ||||
|   results <- query conn qry params | ||||
|   case results of | ||||
|     [row] -> return $ Just row | ||||
|     _     -> return Nothing | ||||
							
								
								
									
										213
									
								
								src/Eval.hs
									
									
									
									
									
								
							
							
						
						
									
										213
									
								
								src/Eval.hs
									
									
									
									
									
								
							| @ -1,35 +1,42 @@ | ||||
| module Eval where | ||||
|  | ||||
| import ContentStore | ||||
| import Parser | ||||
| import Research | ||||
|  | ||||
| import Control.Monad (forM_, foldM) | ||||
| import Data.List (partition, (\\)) | ||||
| import Data.Map  (Map) | ||||
| import Database.SQLite.Simple | ||||
| import qualified Data.Map as Map | ||||
| import qualified Data.Set as Set | ||||
| import qualified Data.Text as T | ||||
| import Data.List (foldl') | ||||
|  | ||||
| evalSingle :: Env -> TricuAST -> Env | ||||
| evalSingle env term | ||||
|   | SDef name [] body <- term | ||||
|   = case Map.lookup name env of | ||||
|       Just existingValue | ||||
|         | existingValue == evalAST env body -> env | ||||
|         | otherwise -> errorWithoutStackTrace $ | ||||
|             "Unable to rebind immutable identifier: " ++ name | ||||
|       Nothing -> | ||||
|         let res = evalAST env body | ||||
|         in Map.insert "!result" res (Map.insert name res env) | ||||
|         | existingValue == evalASTSync env body -> env | ||||
|         | otherwise | ||||
|         -> let res = evalASTSync env body | ||||
|            in Map.insert "!result" res (Map.insert name res env) | ||||
|       Nothing | ||||
|         -> let res = evalASTSync env body | ||||
|            in Map.insert "!result" res (Map.insert name res env) | ||||
|   | SApp func arg <- term | ||||
|   = let res = apply (evalAST env func) (evalAST env arg) | ||||
|       in Map.insert "!result" res env | ||||
|   | SVar name <- term | ||||
|   = let res = apply (evalASTSync env func) (evalASTSync env arg) | ||||
|     in Map.insert "!result" res env | ||||
|   | SVar name Nothing <- 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." | ||||
|       Just v -> Map.insert "!result" v env | ||||
|       Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined" | ||||
|   | SVar name (Just hash) <- term | ||||
|   = errorWithoutStackTrace $ "Hash-specific variable lookup not supported in local evaluation: " ++ name ++ "#" ++ hash | ||||
|   | otherwise | ||||
|   = Map.insert "!result" (evalAST env term) env | ||||
|   = let res = evalASTSync env term | ||||
|     in Map.insert "!result" res env | ||||
|  | ||||
| evalTricu :: Env -> [TricuAST] -> Env | ||||
| evalTricu env x = go env (reorderDefs env x) | ||||
| @ -41,23 +48,84 @@ evalTricu env x = go env (reorderDefs env x) | ||||
|     go env (x:xs) = | ||||
|       evalTricu (evalSingle env x) xs | ||||
|  | ||||
| evalAST :: Env -> TricuAST -> T | ||||
| evalAST env term | ||||
|   | SLambda _ _ <- term = evalAST env (elimLambda 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 | ||||
| evalASTSync :: Env -> TricuAST -> T | ||||
| evalASTSync env term = case term of | ||||
|   SLambda _ _ -> evalASTSync env (elimLambda term) | ||||
|   SVar name Nothing -> case Map.lookup name env of | ||||
|     Just v -> v | ||||
|     Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined" | ||||
|   SVar name (Just hash) -> | ||||
|     case Map.lookup (name ++ "#" ++ hash) env of | ||||
|       Just v -> v | ||||
|       Nothing -> errorWithoutStackTrace $ | ||||
|         "Variable " ++ name ++ " with hash " ++ hash ++ " not found in environment" | ||||
|   TLeaf -> Leaf | ||||
|   TStem t -> Stem (evalASTSync env t) | ||||
|   TFork t u -> Fork (evalASTSync env t) (evalASTSync env u) | ||||
|   SApp t u -> apply (evalASTSync env t) (evalASTSync env u) | ||||
|   SStr s -> ofString s | ||||
|   SInt n -> ofNumber n | ||||
|   SList xs -> ofList (map (evalASTSync env) xs) | ||||
|   SEmpty -> Leaf | ||||
|   _ -> errorWithoutStackTrace $ "Unexpected AST term: " ++ show term | ||||
|  | ||||
| evalAST :: Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T | ||||
| evalAST mconn selectedVersions ast = do | ||||
|   let varNames = collectVarNames ast | ||||
|   resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames | ||||
|   return $ evalASTSync resolvedEnv ast | ||||
|  | ||||
| collectVarNames :: TricuAST -> [(String, Maybe String)] | ||||
| collectVarNames = go [] | ||||
|   where | ||||
|     go acc (SVar name mhash) = (name, mhash) : acc | ||||
|     go acc (SApp t u) = go (go acc t) u | ||||
|     go acc (SLambda vars body) = | ||||
|       let boundVars = Set.fromList vars | ||||
|           collected = go [] body | ||||
|       in acc ++ filter (\(name, _) -> not $ Set.member name boundVars) collected | ||||
|     go acc (TStem t) = go acc t | ||||
|     go acc (TFork t u) = go (go acc t) u | ||||
|     go acc (SList xs) = foldl' go acc xs | ||||
|     go acc _ = acc | ||||
|  | ||||
| resolveTermsFromStore :: Maybe Connection -> Map.Map String T.Text -> [(String, Maybe String)] -> IO Env | ||||
| resolveTermsFromStore Nothing _ _ = return Map.empty | ||||
| resolveTermsFromStore (Just conn) selectedVersions varNames = do | ||||
|   foldM (\env (name, mhash) -> do | ||||
|     term <- resolveTermFromStore conn selectedVersions name mhash | ||||
|     case term of | ||||
|       Just t -> return $ Map.insert (getVarKey name mhash) t env | ||||
|       Nothing -> return env | ||||
|       ) Map.empty varNames | ||||
|   where | ||||
|     getVarKey name Nothing = name | ||||
|     getVarKey name (Just hash) = name ++ "#" ++ hash | ||||
|  | ||||
| resolveTermFromStore :: Connection -> Map.Map String T.Text -> String -> Maybe String -> IO (Maybe T) | ||||
| resolveTermFromStore conn selectedVersions name mhash = case mhash of | ||||
|   Just hashPrefix -> do | ||||
|     versions <- termVersions conn name | ||||
|     let matchingVersions = filter (\(hash, _, _) -> | ||||
|           T.isPrefixOf (T.pack hashPrefix) hash) versions | ||||
|     case matchingVersions of | ||||
|       [] -> return Nothing | ||||
|       [(_, term, _)] -> return $ Just term | ||||
|       _ -> return Nothing -- Ambiguous or too many matches | ||||
|   Nothing -> case Map.lookup name selectedVersions of | ||||
|     Just hash -> do | ||||
|       mterm <- hashToTerm conn hash | ||||
|       case mterm of | ||||
|         Just term -> case deserializeTerm (termData term) of | ||||
|           Right t -> return $ Just t | ||||
|           Left _ -> return Nothing | ||||
|         Nothing -> return Nothing | ||||
|     Nothing -> do | ||||
|       versions <- termVersions conn name | ||||
|       case versions of | ||||
|         [] -> return Nothing | ||||
|         [(_, term, _)] -> return $ Just term | ||||
|         _ -> return $ Just $ (\(_, t, _) -> t) $ head versions | ||||
|  | ||||
| elimLambda :: TricuAST -> TricuAST | ||||
| elimLambda = go | ||||
| @ -69,9 +137,10 @@ elimLambda = go | ||||
|       | lambdaList term     = elimLambda $ lambdaListResult term | ||||
|       | nestedLambda term   = nestedLambdaResult term | ||||
|       | application term    = applicationResult term | ||||
|       | isSList term        = slistTransform term | ||||
|       | otherwise           = term | ||||
|  | ||||
|     etaReduction (SLambda [v] (SApp f (SVar x))) = v == x && not (isFree v f) | ||||
|     etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (isFree v f) | ||||
|     etaReduction _ = False | ||||
|     etaReduceResult (SLambda [_] (SApp f _)) = f | ||||
|  | ||||
| @ -89,52 +158,46 @@ elimLambda = go | ||||
|     nestedLambda (SLambda (_:_) _) = True | ||||
|     nestedLambda _ = False | ||||
|     nestedLambdaResult (SLambda (v:vs) body) | ||||
|       | null vs   = toSKI v (elimLambda body) | ||||
|       | otherwise = elimLambda (SLambda [v] (SLambda vs body)) | ||||
|       | null vs   = toSKI v (go body) -- Changed elimLambda to go | ||||
|       | otherwise = go (SLambda [v] (SLambda vs body)) -- Changed elimLambda to go | ||||
|  | ||||
|     application (SApp _ _) = True | ||||
|     application _ = False | ||||
|     applicationResult (SApp f g) = SApp (elimLambda f) (elimLambda g) | ||||
|     applicationResult (SApp f g) = SApp (go f) (go g) -- Changed elimLambda to go | ||||
|  | ||||
|     toSKI x (SVar y) | ||||
|       | x == y           = _I | ||||
|       | otherwise        = SApp _K (SVar y) | ||||
|     toSKI x t@(SApp n u) | ||||
|       | not (isFree x t) = SApp _K t | ||||
|       | otherwise        = SApp (SApp _S (toSKI x n)) (toSKI x u) | ||||
|     toSKI x (SList xs) | ||||
|       | not (isFree x (SList xs)) = SApp _K (SList xs) | ||||
|       | otherwise = SList (map (toSKI x) xs) | ||||
|     toSKI x t | ||||
|       | not (isFree x t) = SApp _K t | ||||
|       | otherwise        = errorWithoutStackTrace "Unhandled toSKI conversion" | ||||
|     isSList (SList _) = True | ||||
|     isSList _         = False | ||||
|  | ||||
|     slistTransform :: TricuAST -> TricuAST | ||||
|     slistTransform (SList xs) = foldr (\m r -> SApp (SApp TLeaf (go m)) r) TLeaf xs | ||||
|     slistTransform ast = ast -- Should not be reached if isSList is the guard | ||||
|  | ||||
|     toSKI x (SVar y Nothing) | ||||
|       | x == y = _I | ||||
|       | otherwise = SApp _K (SVar y Nothing) | ||||
|     toSKI x (SApp m n) = SApp (SApp _S (toSKI x m)) (toSKI x n) | ||||
|     toSKI x (SLambda [y] body) = toSKI x (toSKI y body) -- This should ideally not happen if lambdas are fully eliminated first | ||||
|     toSKI _ sl@(SList _) = SApp _K (go sl) -- Ensure SList itself is transformed if somehow passed to toSKI directly | ||||
|     toSKI _ term = SApp _K term | ||||
|  | ||||
|     -- Combinators and special forms | ||||
|     _S   = parseSingle "t (t (t t t)) t" | ||||
|     _K   = parseSingle "t t" | ||||
|     _I   = parseSingle "t (t (t t)) t" | ||||
|     _B   = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)" | ||||
|     _TRI = parseSingle "t (t (t t (t (t (t t t))))) t" | ||||
|      | ||||
|     -- Pattern bodies | ||||
|     triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c) | ||||
|     composeBody f g x = SApp (SVar f) (SApp (SVar g) (SVar x)) | ||||
|  | ||||
|     triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a Nothing)) (SVar b Nothing))) (SVar c Nothing) | ||||
|     composeBody f g x = SApp (SVar f Nothing) (SVar g Nothing) -- Note: This might not be the standard B combinator body f(g x) | ||||
|  | ||||
| isFree :: String -> TricuAST -> Bool | ||||
| isFree x = Set.member x . freeVars | ||||
|  | ||||
| freeVars :: TricuAST -> Set.Set String | ||||
| freeVars (SVar    v    ) = Set.singleton v | ||||
| freeVars (SList   s    ) = foldMap freeVars s | ||||
| freeVars (SLambda v b  ) = foldr Set.delete (freeVars b) v | ||||
| freeVars (SApp    f a  ) = freeVars f <> freeVars a | ||||
| freeVars (TFork   l r  ) = freeVars l <> freeVars r | ||||
| freeVars (SDef   _ _ b)  = freeVars b | ||||
| freeVars (TStem   t    ) = freeVars t | ||||
| freeVars (SInt    _    ) = Set.empty | ||||
| freeVars (SStr    _    ) = Set.empty | ||||
| freeVars  TLeaf          = Set.empty | ||||
| freeVars  _              = Set.empty | ||||
| freeVars (SVar v Nothing) = Set.singleton v | ||||
| freeVars (SVar v (Just _)) = Set.singleton v | ||||
| freeVars (SApp t u) = Set.union (freeVars t) (freeVars u) | ||||
| freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs) | ||||
| freeVars _ = Set.empty | ||||
|  | ||||
| reorderDefs :: Env -> [TricuAST] -> [TricuAST] | ||||
| reorderDefs env defs | ||||
| @ -215,3 +278,27 @@ mainResult :: Env -> T | ||||
| mainResult r = case Map.lookup "main" r of | ||||
|   Just  a -> a | ||||
|   Nothing -> errorWithoutStackTrace "No valid definition for `main` found." | ||||
|  | ||||
| evalWithEnv :: Env -> Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T | ||||
| evalWithEnv env mconn selectedVersions ast = do | ||||
|   let varNames = findVarNames ast | ||||
|   resolvedEnv <- case mconn of | ||||
|     Just conn -> foldM (\e name -> | ||||
|       if Map.member name e | ||||
|         then return e | ||||
|         else do | ||||
|           mterm <- resolveTermFromStore conn selectedVersions name Nothing | ||||
|           case mterm of | ||||
|             Just term -> return $ Map.insert name term e | ||||
|             Nothing -> return e | ||||
|       ) env varNames | ||||
|     Nothing -> return env | ||||
|   return $ evalASTSync resolvedEnv ast | ||||
|  | ||||
| findVarNames :: TricuAST -> [String] | ||||
| findVarNames ast = case ast of | ||||
|   SVar name _ -> [name] | ||||
|   SApp a b -> findVarNames a ++ findVarNames b | ||||
|   SLambda args body -> findVarNames body \\ args | ||||
|   SDef name args body -> name : (findVarNames body \\ args) | ||||
|   _ -> [] | ||||
|  | ||||
| @ -109,9 +109,9 @@ nsDefinition moduleName other = | ||||
|   nsBody moduleName other | ||||
|  | ||||
| nsBody :: String -> TricuAST -> TricuAST | ||||
| nsBody moduleName (SVar name) | ||||
|   | isPrefixed name = SVar name | ||||
|   | otherwise = SVar (nsVariable moduleName name) | ||||
| nsBody moduleName (SVar name mhash) | ||||
|   | isPrefixed name = SVar name mhash | ||||
|   | otherwise = SVar (nsVariable moduleName name) mhash | ||||
| nsBody moduleName (SApp func arg) = | ||||
|   SApp (nsBody moduleName func) (nsBody moduleName arg) | ||||
| nsBody moduleName (SLambda args body) = | ||||
| @ -122,18 +122,16 @@ nsBody moduleName (TFork left right) = | ||||
|   TFork (nsBody moduleName left) (nsBody moduleName right) | ||||
| 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) | ||||
|                         args (nsBody moduleName body) | ||||
| nsBody moduleName (SDef name args body) = | ||||
|   SDef (nsVariable moduleName name) args (nsBodyScoped moduleName args body) | ||||
| nsBody _ other = other | ||||
|  | ||||
| nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST | ||||
| nsBodyScoped moduleName args body = case body of | ||||
|   SVar name -> | ||||
|   SVar name mhash -> | ||||
|     if name `elem` args | ||||
|       then SVar name | ||||
|       else nsBody moduleName (SVar name) | ||||
|       then SVar name mhash | ||||
|       else nsBody moduleName (SVar name mhash) | ||||
|   SApp func arg -> | ||||
|     SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg) | ||||
|   SLambda innerArgs innerBody -> | ||||
| @ -141,13 +139,11 @@ nsBodyScoped moduleName args body = case body of | ||||
|   SList items -> | ||||
|     SList (map (nsBodyScoped moduleName args) items) | ||||
|   TFork left right -> | ||||
|     TFork (nsBodyScoped moduleName args left) | ||||
|           (nsBodyScoped moduleName args right) | ||||
|     TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right) | ||||
|   TStem subtree -> | ||||
|     TStem (nsBodyScoped moduleName args subtree) | ||||
|   SDef name innerArgs innerBody -> | ||||
|     SDef (nsVariable moduleName name) innerArgs | ||||
|          (nsBodyScoped moduleName (args ++ innerArgs) innerBody) | ||||
|     SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody) | ||||
|   other -> other | ||||
|  | ||||
| isPrefixed :: String -> Bool | ||||
|  | ||||
							
								
								
									
										24
									
								
								src/Lexer.hs
									
									
									
									
									
								
							
							
						
						
									
										24
									
								
								src/Lexer.hs
									
									
									
									
									
								
							| @ -35,6 +35,7 @@ tricuLexer = do | ||||
|       [ try lnewline | ||||
|       , try namespace | ||||
|       , try dot | ||||
|       , try identifierWithHash | ||||
|       , try identifier | ||||
|       , try keywordT | ||||
|       , try integerLiteral | ||||
| @ -56,12 +57,33 @@ lexTricu input = case runParser tricuLexer "" input of | ||||
| keywordT :: Lexer LToken | ||||
| keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT | ||||
|  | ||||
| identifierWithHash :: Lexer LToken | ||||
| identifierWithHash = do | ||||
|   first <- lowerChar <|> char '_' | ||||
|   rest  <- many $ letterChar | ||||
|               <|> digitChar <|> char '_' <|> char '-' <|> char '?' | ||||
|               <|> char '$'  <|> char '@' <|> char '%' | ||||
|   _ <- char '#' -- Consume '#' | ||||
|   hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash | ||||
|                 <?> "hash characters (alphanumeric or hyphen)" | ||||
|  | ||||
|   let name = first : rest | ||||
|   let hashLen = length hashString | ||||
|   if name == "t" || name == "!result" | ||||
|     then fail "Keywords (`t`, `!result`) cannot be used with a hash suffix." | ||||
|     else if hashLen < 16 then | ||||
|       fail $ "Hash suffix for '" ++ name ++ "' must be at least 16 characters long. Got " ++ show hashLen ++ " ('" ++ hashString ++ "')." | ||||
|     else if hashLen > 64 then -- Assuming SHA256, max 64 | ||||
|       fail $ "Hash suffix for '" ++ name ++ "' cannot be longer than 64 characters (SHA256). Got " ++ show hashLen ++ " ('" ++ hashString ++ "')." | ||||
|     else | ||||
|       return (LIdentifierWithHash name hashString) | ||||
|  | ||||
| identifier :: Lexer LToken | ||||
| identifier = do | ||||
|   first <- lowerChar <|> char '_' | ||||
|   rest  <- many $ letterChar | ||||
|               <|> digitChar <|> char '_' <|> char '-' <|> char '?' | ||||
|               <|> char '$'  <|> char '#' <|> char '@' <|> char '%' | ||||
|               <|> char '$'  <|> char '@' <|> char '%' | ||||
|   let name = first : rest | ||||
|   if name == "t" || name == "!result" | ||||
|     then fail "Keywords (`t`, `!result`) cannot be used as an identifier" | ||||
|  | ||||
| @ -5,6 +5,7 @@ import FileEval | ||||
| import Parser                 (parseTricu) | ||||
| import REPL | ||||
| import Research | ||||
| import ContentStore | ||||
|  | ||||
| import Control.Monad          (foldM) | ||||
| import Control.Monad.IO.Class (liftIO) | ||||
| @ -64,8 +65,7 @@ main = do | ||||
|     Repl -> do | ||||
|       putStrLn "Welcome to the tricu REPL" | ||||
|       putStrLn "You may exit with `CTRL+D` or the `!exit` command." | ||||
|       putStrLn "Try typing `!` with tab completion for more commands." | ||||
|       repl Map.empty | ||||
|       repl | ||||
|     Evaluate { file = filePaths, form = form } -> do | ||||
|       result <- case filePaths of | ||||
|         [] -> runTricuT <$> getContents | ||||
| @ -81,8 +81,6 @@ main = do | ||||
|         (filePath:_) -> readFile filePath | ||||
|       putStrLn $ decodeResult $ result $ evalTricu Map.empty $ parseTricu value | ||||
|  | ||||
| -- Simple interfaces | ||||
|  | ||||
| runTricu :: String -> String | ||||
| runTricu = formatT TreeCalculus . runTricuT | ||||
|  | ||||
| @ -125,4 +123,4 @@ runTricuEnvWithEnv env input = | ||||
|   let asts     = parseTricu input | ||||
|       finalEnv = evalTricu env asts | ||||
|       res      = result finalEnv | ||||
|    in (finalEnv, formatT TreeCalculus res) | ||||
|    in (finalEnv, formatT TreeCalculus res) | ||||
|  | ||||
| @ -249,7 +249,7 @@ parseGroupedItemM = do | ||||
| parseSingleItemM :: ParserM TricuAST | ||||
| parseSingleItemM = do | ||||
|   token <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False) | ||||
|   if | LIdentifier name <- token -> pure (SVar name) | ||||
|   if | LIdentifier name <- token -> pure (SVar name Nothing) | ||||
|      | token == LKeywordT        -> pure TLeaf | ||||
|      | otherwise                 -> fail "Unexpected token in list item" | ||||
|  | ||||
| @ -258,16 +258,25 @@ parseVarM = do | ||||
|   token <- satisfyM (\case | ||||
|     LNamespace _ -> True | ||||
|     LIdentifier _ -> True | ||||
|     LIdentifierWithHash _ _ -> True | ||||
|     _ -> False) | ||||
|  | ||||
|   case token of | ||||
|     LNamespace ns -> do | ||||
|       _ <- satisfyM (== LDot) | ||||
|       LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False) | ||||
|       pure $ SVar (ns ++ "." ++ name) | ||||
|       pure $ SVar (ns ++ "." ++ name) Nothing | ||||
|  | ||||
|     LIdentifier name | ||||
|       | name == "t" || name == "!result" -> | ||||
|         fail ("Reserved keyword: " ++ name ++ " cannot be assigned.") | ||||
|       | otherwise -> pure (SVar name) | ||||
|       | otherwise -> pure (SVar name Nothing) | ||||
|  | ||||
|     LIdentifierWithHash name hash -> | ||||
|       if name == "t" || name == "!result" | ||||
|         then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.") | ||||
|         else pure (SVar name (Just hash)) | ||||
|  | ||||
|     _ -> fail "Unexpected token while parsing variable" | ||||
|  | ||||
| parseIntLiteralM :: ParserM TricuAST | ||||
| @ -275,7 +284,7 @@ parseIntLiteralM = do | ||||
|   let intL = (\case LIntegerLiteral _ -> True; _ -> False) | ||||
|   token <- satisfyM intL | ||||
|   if | LIntegerLiteral value <- token -> | ||||
|        pure (SInt value) | ||||
|        pure (SInt (fromIntegral value)) | ||||
|      | otherwise                      -> | ||||
|        fail "Unexpected token while parsing integer literal" | ||||
|  | ||||
|  | ||||
							
								
								
									
										624
									
								
								src/REPL.hs
									
									
									
									
									
								
							
							
						
						
									
										624
									
								
								src/REPL.hs
									
									
									
									
									
								
							| @ -5,6 +5,17 @@ import FileEval | ||||
| import Lexer | ||||
| import Parser | ||||
| import Research | ||||
| import ContentStore | ||||
|  | ||||
| import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId) | ||||
| import Control.Monad (forever, void, when, forM, forM_, foldM, unless) | ||||
| import Data.ByteString (ByteString) | ||||
| import Data.Maybe (isNothing, isJust, fromJust, catMaybes) | ||||
| import Database.SQLite.Simple (Connection, Only(..), query, query_, execute, execute_, open) | ||||
| import System.Directory (doesFileExist, createDirectoryIfMissing) | ||||
| import System.FSNotify | ||||
| import System.FilePath (takeDirectory, (</>)) | ||||
| import Text.Read (readMaybe) | ||||
|  | ||||
| import Control.Exception         (IOException, SomeException, catch | ||||
|                                  , displayException) | ||||
| @ -14,17 +25,37 @@ import Control.Monad.IO.Class    (liftIO) | ||||
| import Control.Monad.Trans.Class (lift) | ||||
| import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) | ||||
| import Data.Char                 (isSpace, isUpper) | ||||
| import Data.List                 (dropWhile, dropWhileEnd, isPrefixOf) | ||||
| import Data.List                 ((\\), dropWhile, dropWhileEnd, isPrefixOf, nub, sortBy, groupBy, intercalate, find) | ||||
| import Data.Version (showVersion) | ||||
| import Paths_tricu (version) | ||||
| import System.Console.Haskeline | ||||
| import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..),  | ||||
|                            Color(..), ConsoleIntensity(..), clearFromCursorToLineEnd) | ||||
|  | ||||
| import qualified Data.Map as Map | ||||
| import qualified Data.Text as T | ||||
| import qualified Data.Text.IO as T | ||||
|  | ||||
| repl :: Env -> IO () | ||||
| repl env = runInputT settings (withInterrupt (loop env Decode)) | ||||
| import Control.Concurrent (forkIO, threadDelay) | ||||
| import Data.IORef (IORef, newIORef, readIORef, writeIORef) | ||||
| import Data.Time (UTCTime, getCurrentTime, diffUTCTime) | ||||
| import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar) | ||||
|  | ||||
| import Data.Time.Format (formatTime, defaultTimeLocale) | ||||
| import Data.Time.Clock.POSIX (posixSecondsToUTCTime) | ||||
|  | ||||
| data REPLState = REPLState | ||||
|   { replForm :: EvaluatedForm | ||||
|   , replContentStore :: Maybe Connection | ||||
|   , replWatchedFile :: Maybe FilePath | ||||
|   , replSelectedVersions :: Map.Map String T.Text | ||||
|   , replWatcherThread :: Maybe ThreadId | ||||
|   } | ||||
|  | ||||
| repl :: IO () | ||||
| repl = do | ||||
|   conn <- ContentStore.initContentStore  | ||||
|   runInputT settings (withInterrupt (loop (REPLState Decode (Just conn) Nothing Map.empty Nothing))) | ||||
|   where | ||||
|     settings :: Settings IO | ||||
|     settings = Settings | ||||
| @ -39,49 +70,64 @@ repl env = runInputT settings (withInterrupt (loop env Decode)) | ||||
|       where | ||||
|         commands = [ "!exit" | ||||
|                    , "!output" | ||||
|                    , "!definitions" | ||||
|                    , "!import" | ||||
|                    , "!clear" | ||||
|                    , "!save" | ||||
|                    , "!reset" | ||||
|                    , "!version" | ||||
|                    , "!help" | ||||
|                    , "!definitions" | ||||
|                    , "!watch" | ||||
|                    , "!refresh" | ||||
|                    , "!versions" | ||||
|                    , "!select" | ||||
|                    , "!tag" | ||||
|                    ] | ||||
|  | ||||
|     loop :: Env -> EvaluatedForm -> InputT IO () | ||||
|     loop env form = handle (interruptHandler env form) $ do | ||||
|     loop :: REPLState -> InputT IO () | ||||
|     loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do | ||||
|       minput <- getInputLine "tricu < " | ||||
|       case minput of | ||||
|         Nothing -> outputStrLn "Exiting tricu" | ||||
|         Nothing -> return () | ||||
|         Just s | ||||
|           | strip s == "" -> loop env form | ||||
|           | strip s == "" -> loop state | ||||
|           | strip s == "!exit" -> outputStrLn "Exiting tricu" | ||||
|           | strip s == "!clear" -> do | ||||
|               liftIO $ putStr "\ESC[2J\ESC[H" | ||||
|               loop env form | ||||
|               loop state | ||||
|           | strip s == "!reset" -> do | ||||
|               outputStrLn "Environment reset to initial state" | ||||
|               loop Map.empty form | ||||
|           | strip s == "!version" -> do | ||||
|               outputStrLn "Selected versions reset" | ||||
|               loop state { replSelectedVersions = Map.empty } | ||||
|           | strip s == "!help" -> do | ||||
|               outputStrLn $ "tricu version " ++ showVersion version | ||||
|               loop env form | ||||
|           | "!save" `isPrefixOf` strip s -> handleSave env form | ||||
|           | strip s == "!output" -> handleOutput env form | ||||
|           | 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 form | ||||
|           | "!import" `isPrefixOf` strip s -> handleImport env form | ||||
|           | take 2 s == "--" -> loop env form | ||||
|               outputStrLn "Available commands:" | ||||
|               outputStrLn "  !exit        - Exit the REPL" | ||||
|               outputStrLn "  !clear       - Clear the screen" | ||||
|               outputStrLn "  !reset       - Reset preferences for selected versions" | ||||
|               outputStrLn "  !help        - Show tricu version and available commands" | ||||
|               outputStrLn "  !output      - Change output format (tree|fsl|ast|ternary|ascii|decode)" | ||||
|               outputStrLn "  !definitions - List all defined terms in the content store" | ||||
|               outputStrLn "  !import      - Import definitions from file to the content store" | ||||
|               outputStrLn "  !watch       - Watch a file for changes, evaluate terms, and store them" | ||||
|               outputStrLn "  !versions    - Show all versions of a term by name" | ||||
|               outputStrLn "  !select      - Select a specific version of a term for subsequent lookups" | ||||
|               outputStrLn "  !tag         - Add or update a tag for a term by hash or name" | ||||
|               loop state | ||||
|           | strip s == "!output" -> handleOutput state | ||||
|           | strip s == "!definitions" -> handleDefinitions state | ||||
|           | "!import" `isPrefixOf` strip s -> handleImport state | ||||
|           | "!watch" `isPrefixOf` strip s -> handleWatch state | ||||
|           | strip s == "!refresh" -> handleRefresh state | ||||
|           | "!versions" `isPrefixOf` strip s -> handleVersions state | ||||
|           | "!select" `isPrefixOf` strip s -> handleSelect state | ||||
|           | "!tag" `isPrefixOf` strip s -> handleTag state | ||||
|           | take 2 s == "--" -> loop state | ||||
|           | otherwise -> do | ||||
|               newEnv <- liftIO $ processInput env s form `catch` errorHandler env | ||||
|               loop newEnv form | ||||
|               result <- liftIO $ catch | ||||
|                 (processInput state s) | ||||
|                 (errorHandler state) | ||||
|               loop result | ||||
|  | ||||
|     handleOutput :: Env -> EvaluatedForm -> InputT IO () | ||||
|     handleOutput env currentForm = do | ||||
|     handleOutput :: REPLState -> InputT IO () | ||||
|     handleOutput state = do | ||||
|       let formats = [Decode, TreeCalculus, FSL, AST, Ternary, Ascii] | ||||
|       outputStrLn "Available output formats:" | ||||
|       mapM_ (\(i, f) -> outputStrLn $ show i ++ ". " ++ show f) | ||||
| @ -97,94 +143,462 @@ repl env = runInputT settings (withInterrupt (loop env Decode)) | ||||
|       case result of | ||||
|         Nothing -> do | ||||
|           outputStrLn "Invalid selection. Keeping current output format." | ||||
|           loop env currentForm | ||||
|           loop state | ||||
|         Just newForm -> do | ||||
|           outputStrLn $ "Output format changed to: " ++ show newForm | ||||
|           loop env newForm | ||||
|           loop state { replForm = newForm } | ||||
|  | ||||
|     handleImport :: Env -> EvaluatedForm -> InputT IO () | ||||
|     handleImport env form = do | ||||
|       res <- runMaybeT $ do | ||||
|         let fset = setComplete completeFilename defaultSettings | ||||
|         path <- MaybeT $ runInputT fset $ | ||||
|           getInputLineWithInitial "File path to load < " ("", "") | ||||
|     handleDefinitions :: REPLState -> InputT IO () | ||||
|     handleDefinitions state = case replContentStore state of | ||||
|       Nothing -> do | ||||
|         liftIO $ printError "Content store not initialized" | ||||
|         loop state | ||||
|       Just conn -> do | ||||
|         terms <- liftIO $ ContentStore.listStoredTerms conn | ||||
|          | ||||
|         if null terms | ||||
|           then do | ||||
|             liftIO $ printWarning "No terms in content store." | ||||
|             loop state | ||||
|           else do | ||||
|             liftIO $ do | ||||
|               printSuccess $ "Content store contains " ++ show (length terms) ++ " terms:" | ||||
|  | ||||
|         text <- MaybeT $ liftIO $ handle (\e -> do | ||||
|             putStrLn $ "Error reading file: " ++ displayException (e :: IOException) | ||||
|             return Nothing | ||||
|           ) $ Just <$> readFile (strip path) | ||||
|             let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms | ||||
|  | ||||
|         case parseProgram (lexTricu text) of | ||||
|           Left err -> do | ||||
|             lift $ outputStrLn $ "Parse error: " ++ handleParseError err | ||||
|             MaybeT $ return Nothing | ||||
|           Right ast -> do | ||||
|             ns <- MaybeT $ runInputT defaultSettings $ | ||||
|               getInputLineWithInitial "Namespace (or !Local for no namespace) < " ("", "") | ||||
|             forM_ terms $ \term -> do | ||||
|               let namesStr = T.unpack (termNames term) | ||||
|                   hash = termHash term | ||||
|                   padding = replicate (maxNameWidth - length namesStr) ' ' | ||||
|                    | ||||
|               liftIO $ do | ||||
|                 putStr "  " | ||||
|                 printVariable namesStr | ||||
|                 putStr padding | ||||
|                 putStr " [hash: " | ||||
|                 displayColoredHash hash | ||||
|                 putStrLn "]" | ||||
|                  | ||||
|                 tags <- ContentStore.termToTags conn hash  | ||||
|                 unless (null tags) $ displayTags tags | ||||
|  | ||||
|             let name = strip ns | ||||
|             if (name /= "!Local" && (null name || not (isUpper (head name)))) then do | ||||
|                 lift $ outputStrLn "Namespace must start with an uppercase letter" | ||||
|                 MaybeT $ return Nothing | ||||
|             else do | ||||
|                 prog <- liftIO $ preprocessFile (strip path) | ||||
|                 let code = case name of | ||||
|                       "!Local" -> prog | ||||
|                       _ -> nsDefinitions name prog | ||||
|                     env' = evalTricu env code | ||||
|                 return env' | ||||
|       case res of | ||||
|             loop state | ||||
|  | ||||
|     handleImport :: REPLState -> InputT IO () | ||||
|     handleImport state = do | ||||
|       let fset = setComplete completeFilename defaultSettings | ||||
|       filename <- runInputT fset $ getInputLineWithInitial "File to import: " ("", "") | ||||
|       case filename of | ||||
|         Nothing -> loop state | ||||
|         Just f -> do | ||||
|           let cleanFilename = strip f | ||||
|           exists <- liftIO $ doesFileExist cleanFilename | ||||
|           if not exists | ||||
|             then do | ||||
|               liftIO $ printError $ "File not found: " ++ cleanFilename | ||||
|               loop state | ||||
|             else importFile state cleanFilename | ||||
|  | ||||
|     importFile :: REPLState -> String -> InputT IO () | ||||
|     importFile state cleanFilename = do | ||||
|       code <- liftIO $ readFile cleanFilename | ||||
|       case replContentStore state of | ||||
|         Nothing -> do | ||||
|           outputStrLn "Import cancelled" | ||||
|           loop env form | ||||
|         Just env' -> | ||||
|           loop (Map.delete "!result" env') form | ||||
|           liftIO $ printError "Content store not initialized" | ||||
|           loop state | ||||
|         Just conn -> do | ||||
|           env <- liftIO $ evaluateFile cleanFilename | ||||
|            | ||||
|           liftIO $ do | ||||
|             printSuccess $ "Importing file: " ++ cleanFilename | ||||
|             let defs = Map.toList $ Map.delete "!result" env | ||||
|              | ||||
|             importedCount <- foldM (\count (name, term) -> do | ||||
|               hash <- ContentStore.storeTerm conn [name] term | ||||
|               printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash | ||||
|               return (count + 1) | ||||
|               ) 0 defs | ||||
|              | ||||
|             printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully" | ||||
|            | ||||
|           loop state | ||||
|  | ||||
|     interruptHandler :: Env -> EvaluatedForm -> Interrupt -> InputT IO () | ||||
|     interruptHandler env form _ = do | ||||
|       outputStrLn "Interrupted with CTRL+C\n\ | ||||
|                   \You can use the !exit command or CTRL+D to exit" | ||||
|       loop env form | ||||
|     handleWatch :: REPLState -> InputT IO () | ||||
|     handleWatch state = do | ||||
|       dbPath <- liftIO ContentStore.getContentStorePath | ||||
|       let filepath = takeDirectory dbPath </> "scratch.tri" | ||||
|       let dirPath = takeDirectory filepath | ||||
|  | ||||
|     processInput :: Env -> String -> EvaluatedForm -> IO Env | ||||
|     processInput env input form = do | ||||
|       let asts   = parseTricu input | ||||
|           newEnv = evalTricu env asts | ||||
|       case Map.lookup "!result" newEnv of | ||||
|         Just r -> do | ||||
|           putStrLn $ "tricu > " ++ formatT form r | ||||
|         Nothing -> pure () | ||||
|       return newEnv | ||||
|       liftIO $ createDirectoryIfMissing True dirPath | ||||
|  | ||||
|     errorHandler :: Env -> SomeException -> IO (Env) | ||||
|     errorHandler env e = do | ||||
|       putStrLn $ "Error: " ++ show e | ||||
|       return env | ||||
|       fileExists <- liftIO $ doesFileExist filepath | ||||
|       unless fileExists $ liftIO $ writeFile filepath "-- tricu scratch file\n\n" | ||||
|  | ||||
|       outputStrLn $ "Using scratch file: " ++ filepath | ||||
|  | ||||
|       when (isJust (replWatcherThread state)) $ do | ||||
|         outputStrLn "Stopping previous file watch" | ||||
|         liftIO $ killThread (fromJust $ replWatcherThread state) | ||||
|  | ||||
|       outputStrLn $ "Starting to watch file: " ++ filepath | ||||
|       outputStrLn "Press Ctrl+C to stop watching and return to REPL" | ||||
|  | ||||
|       liftIO $ processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state) | ||||
|  | ||||
|       lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime | ||||
|  | ||||
|       watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do | ||||
|         stopAction <- watchDir mgr dirPath (\event -> eventPath event == filepath) $ \event -> do | ||||
|           now <- getCurrentTime | ||||
|           lastProcessed <- readIORef lastProcessedRef | ||||
|           when (diffUTCTime now lastProcessed > 0.5) $ do | ||||
|             putStrLn $ "\nFile changed: " ++ filepath | ||||
|             processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state) | ||||
|             writeIORef lastProcessedRef now | ||||
|         forever $ threadDelay 1000000 | ||||
|  | ||||
|       watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId } | ||||
|  | ||||
|     handleUnwatch :: REPLState -> InputT IO () | ||||
|     handleUnwatch state = case replWatchedFile state of | ||||
|       Nothing -> do | ||||
|         outputStrLn "No file is currently being watched" | ||||
|         loop state | ||||
|       Just path -> do | ||||
|         outputStrLn $ "Stopped watching " ++ path | ||||
|         when (isJust (replWatcherThread state)) $ do | ||||
|           liftIO $ killThread (fromJust $ replWatcherThread state) | ||||
|         loop state { replWatchedFile = Nothing, replWatcherThread = Nothing } | ||||
|  | ||||
|     handleRefresh :: REPLState -> InputT IO () | ||||
|     handleRefresh state = case replContentStore state of | ||||
|       Nothing -> do | ||||
|         outputStrLn "Content store not initialized" | ||||
|         loop state | ||||
|       Just conn -> do | ||||
|         outputStrLn "Environment refreshed from content store (definitions are live)" | ||||
|         loop state | ||||
|  | ||||
|     handleVersions :: REPLState -> InputT IO () | ||||
|     handleVersions state = case replContentStore state of | ||||
|       Nothing -> do | ||||
|         liftIO $ printError "Content store not initialized" | ||||
|         loop state | ||||
|       Just conn -> do | ||||
|         liftIO $ printPrompt "Term name: " | ||||
|         nameInput <- getInputLine "" | ||||
|         case nameInput of | ||||
|           Nothing -> loop state | ||||
|           Just n -> do | ||||
|             let termName = strip n | ||||
|             versions <- liftIO $ ContentStore.termVersions conn termName | ||||
|             if null versions | ||||
|               then liftIO $ printError $ "No versions found for term: " ++ termName | ||||
|               else do | ||||
|                 liftIO $ do | ||||
|                   printKeyword "Versions of " | ||||
|                   printVariable termName | ||||
|                   putStrLn ":" | ||||
|                    | ||||
|                   forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do | ||||
|                     tags <- ContentStore.termToTags conn hash | ||||
|                     putStr $ show (i :: Int) ++ ". " | ||||
|                     displayColoredHash hash | ||||
|                     putStr $ " (" ++ formatTimestamp ts ++ ")" | ||||
|                     unless (null tags) $ do | ||||
|                       putStr " [" | ||||
|                       printKeyword "Tags: " | ||||
|                       forM_ (zip [0..] tags) $ \(j, tag) -> do | ||||
|                         printTag (T.unpack tag) | ||||
|                         when (j < length tags - 1) $ putStr ", " | ||||
|                       putStr "]" | ||||
|                     putStrLn "" | ||||
|         loop state | ||||
|  | ||||
|     handleSelect :: REPLState -> InputT IO () | ||||
|     handleSelect state = case replContentStore state of | ||||
|       Nothing -> do | ||||
|         liftIO $ printError "Content store not initialized" | ||||
|         loop state | ||||
|       Just conn -> do | ||||
|         liftIO $ printPrompt "Term name: " | ||||
|         nameInput <- getInputLine "" | ||||
|         case nameInput of | ||||
|           Nothing -> loop state | ||||
|           Just n -> do | ||||
|             let cleanName = strip n | ||||
|             versions <- liftIO $ ContentStore.termVersions conn cleanName | ||||
|             if null versions | ||||
|               then do | ||||
|                 liftIO $ printError $ "No versions found for term: " ++ cleanName | ||||
|                 loop state | ||||
|               else do | ||||
|                 liftIO $ do | ||||
|                   printKeyword "Versions of " | ||||
|                   printVariable cleanName | ||||
|                   putStrLn ":" | ||||
|                    | ||||
|                   forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do | ||||
|                     tags <- ContentStore.termToTags conn hash | ||||
|                     putStr $ show (i :: Int) ++ ". " | ||||
|                     displayColoredHash hash | ||||
|                     putStr $ " (" ++ formatTimestamp ts ++ ")" | ||||
|                     unless (null tags) $ do | ||||
|                       putStr " [" | ||||
|                       printKeyword "Tags: " | ||||
|                       forM_ (zip [0..] tags) $ \(j, tag) -> do | ||||
|                         printTag (T.unpack tag) | ||||
|                         when (j < length tags - 1) $ putStr ", " | ||||
|                       putStr "]" | ||||
|                     putStrLn "" | ||||
|  | ||||
|                 liftIO $ printPrompt "Select version (number or full hash, Enter to cancel): " | ||||
|                 choiceInput <- getInputLine "" | ||||
|                 let choice = strip <$> choiceInput | ||||
|  | ||||
|                 selectedHash <- case choice of | ||||
|                     Just selectedStr | not (null selectedStr) -> do | ||||
|                         case readMaybe selectedStr :: Maybe Int of | ||||
|                             Just idx | idx > 0 && idx <= length versions -> do | ||||
|                                 let (h, _, _) = versions !! (idx - 1) | ||||
|                                 return $ Just h | ||||
|                             _ -> do | ||||
|                                 let potentialHash = T.pack selectedStr | ||||
|                                 let foundByHash = find (\(h, _, _) -> T.isPrefixOf potentialHash h) versions | ||||
|                                 case foundByHash of | ||||
|                                     Just (h, _, _) -> return $ Just h | ||||
|                                     Nothing -> do | ||||
|                                         liftIO $ printError "Invalid selection or hash not found in list." | ||||
|                                         return Nothing | ||||
|                     _ -> return Nothing | ||||
|  | ||||
|                 case selectedHash of | ||||
|                     Just hashToSelect -> do | ||||
|                         let newState = state { replSelectedVersions = | ||||
|                                               Map.insert cleanName hashToSelect (replSelectedVersions state) } | ||||
|                         liftIO $ do | ||||
|                           printSuccess "Selected version " | ||||
|                           displayColoredHash hashToSelect | ||||
|                           putStr " for term " | ||||
|                           printVariable cleanName | ||||
|                           putStrLn "" | ||||
|                         loop newState | ||||
|                     Nothing -> loop state | ||||
|  | ||||
|     handleTag :: REPLState -> InputT IO () | ||||
|     handleTag state = case replContentStore state of | ||||
|       Nothing -> do | ||||
|         liftIO $ printError "Content store not initialized" | ||||
|         loop state | ||||
|       Just conn -> do | ||||
|         liftIO $ printPrompt "Term hash (full or prefix) or name (most recent version will be used): " | ||||
|         identInput <- getInputLine "" | ||||
|         case identInput of | ||||
|           Nothing -> loop state | ||||
|           Just ident -> do | ||||
|             let cleanIdent = strip ident | ||||
|              | ||||
|             mFullHash <- liftIO $ resolveIdentifierToHash conn cleanIdent | ||||
|  | ||||
|             case mFullHash of | ||||
|               Nothing -> do | ||||
|                 liftIO $ printError $ "Could not resolve identifier: " ++ cleanIdent | ||||
|                 loop state | ||||
|               Just fullHash -> do | ||||
|                 liftIO $ do | ||||
|                     putStr "Tagging term with hash: " | ||||
|                     displayColoredHash fullHash | ||||
|                     putStrLn "" | ||||
|                 tags <- liftIO $ ContentStore.termToTags conn fullHash | ||||
|                 unless (null tags) $ do | ||||
|                   liftIO $ do | ||||
|                     printKeyword "Existing tags:" | ||||
|                     displayTags tags | ||||
|  | ||||
|                 liftIO $ printPrompt "Tag to add/set: " | ||||
|                 tagValueInput <- getInputLine "" | ||||
|                 case tagValueInput of | ||||
|                   Nothing -> loop state | ||||
|                   Just tv -> do | ||||
|                     let tagVal = T.pack (strip tv) | ||||
|                     liftIO $ do | ||||
|                       ContentStore.setTag conn fullHash tagVal  | ||||
|                       printSuccess $ "Tag '" | ||||
|                       printTag (T.unpack tagVal) | ||||
|                       putStr "' set for term with hash " | ||||
|                       displayColoredHash fullHash | ||||
|                       putStrLn "" | ||||
|                     loop state | ||||
|  | ||||
|     resolveIdentifierToHash :: Connection -> String -> IO (Maybe T.Text) | ||||
|     resolveIdentifierToHash conn ident | ||||
|         | T.pack "#" `T.isInfixOf` T.pack ident = do | ||||
|             let hashPrefix = T.pack ident | ||||
|             matchingHashes <- liftIO $ query conn "SELECT hash FROM terms WHERE hash LIKE ?" (Only (hashPrefix <> "%")) :: IO [Only T.Text] | ||||
|             case matchingHashes of | ||||
|                 [Only fullHash] -> return $ Just fullHash | ||||
|                 [] -> do printError $ "No hash found starting with: " ++ T.unpack hashPrefix; return Nothing | ||||
|                 _  -> do printError $ "Ambiguous hash prefix: " ++ T.unpack hashPrefix; return Nothing | ||||
|         | otherwise = do | ||||
|             versions <- ContentStore.termVersions conn ident | ||||
|             if null versions | ||||
|             then do printError $ "No versions found for term name: " ++ ident; return Nothing | ||||
|             else return $ Just $ (\(h,_,_) -> h) $ head versions | ||||
|  | ||||
|     interruptHandler :: REPLState -> Interrupt -> InputT IO () | ||||
|     interruptHandler state _ = do | ||||
|       liftIO $ do | ||||
|         printWarning "Interrupted with CTRL+C" | ||||
|         printWarning "You can use the !exit command or CTRL+D to exit" | ||||
|       loop state | ||||
|  | ||||
|     errorHandler :: REPLState -> SomeException -> IO REPLState | ||||
|     errorHandler state e = do | ||||
|       printError $ "Error: " ++ displayException e | ||||
|       return state | ||||
|  | ||||
|     processInput :: REPLState -> String -> IO REPLState | ||||
|     processInput state input = do | ||||
|       let asts = parseTricu input | ||||
|       case asts of | ||||
|         [] -> return state | ||||
|         _ -> case replContentStore state of | ||||
|           Nothing -> do | ||||
|             printError "Content store not initialized" | ||||
|             return state | ||||
|           Just conn -> do | ||||
|             newState <- foldM (\s astNode -> do | ||||
|               let varsInAst = Eval.findVarNames astNode | ||||
|               foldM (\currentSelectionState varName -> | ||||
|                 if Map.member varName (replSelectedVersions currentSelectionState) | ||||
|                   then return currentSelectionState | ||||
|                   else do | ||||
|                     versions <- ContentStore.termVersions conn varName | ||||
|                     if length versions > 1 | ||||
|                       then do | ||||
|                         let (latestHash, _, _) = head versions | ||||
|                         liftIO $ printWarning $ "Multiple versions of '" ++ varName ++ "' found. Using most recent." | ||||
|                         return currentSelectionState { replSelectedVersions = Map.insert varName latestHash (replSelectedVersions currentSelectionState) } | ||||
|                       else return currentSelectionState | ||||
|                 ) s varsInAst | ||||
|               ) state asts | ||||
|  | ||||
|             forM_ asts $ \ast -> do | ||||
|               case ast of | ||||
|                 SDef name [] body -> do | ||||
|                   result <- evalAST (Just conn) (replSelectedVersions newState) body | ||||
|                   hash <- ContentStore.storeTerm conn [name] result | ||||
|                    | ||||
|                   liftIO $ do | ||||
|                     putStr "tricu > " | ||||
|                     printSuccess "Stored definition: " | ||||
|                     printVariable name | ||||
|                     putStr " with hash " | ||||
|                     displayColoredHash hash | ||||
|                     putStrLn "" | ||||
|                      | ||||
|                     putStr "tricu > " | ||||
|                     printResult $ formatT (replForm newState) result | ||||
|                     putStrLn "" | ||||
|  | ||||
|                 _ -> do | ||||
|                   result <- evalAST (Just conn) (replSelectedVersions newState) ast | ||||
|                   liftIO $ do | ||||
|                     putStr "tricu > " | ||||
|                     printResult $ formatT (replForm newState) result | ||||
|                     putStrLn "" | ||||
|             return newState | ||||
|  | ||||
|     strip :: String -> String | ||||
|     strip = dropWhileEnd isSpace . dropWhile isSpace | ||||
|  | ||||
|     handleSave :: Env -> EvaluatedForm -> InputT IO () | ||||
|     handleSave env form = do | ||||
|       let fset = setComplete completeFilename defaultSettings | ||||
|       path <- runInputT fset $ | ||||
|         getInputLineWithInitial "File to save < " ("", "") | ||||
|     watchLoop :: REPLState -> InputT IO () | ||||
|     watchLoop state = handle (\Interrupt -> do | ||||
|                                 outputStrLn "\nStopped watching file" | ||||
|                                 when (isJust (replWatcherThread state)) $ do | ||||
|                                   liftIO $ killThread (fromJust $ replWatcherThread state) | ||||
|                                 loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }) $ do | ||||
|       liftIO $ threadDelay 1000000 | ||||
|       watchLoop state | ||||
|  | ||||
|       case path of | ||||
|         Nothing -> do | ||||
|           outputStrLn "Save cancelled" | ||||
|           loop env form | ||||
|         Just p -> do | ||||
|           let definitions = Map.toList $ Map.delete "!result" env | ||||
|               filepath = strip p | ||||
|     processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO () | ||||
|     processWatchedFile filepath mconn selectedVersions outputForm = do | ||||
|       content <- readFile filepath | ||||
|       let asts = parseTricu content | ||||
|  | ||||
|           outputStrLn "Starting save..." | ||||
|           liftIO $ writeFile filepath "" | ||||
|           outputStrLn "File created..." | ||||
|           forM_ definitions $ \(name, value) -> do | ||||
|             let content = name ++ " = " ++ formatT TreeCalculus value ++ "\n" | ||||
|             outputStrLn $ "Writing definition: " ++ name ++ " with length " ++ show (length content) | ||||
|             liftIO $ appendFile filepath content | ||||
|           outputStrLn $ "Saved " ++ show (length definitions) ++ " definitions to " ++ p | ||||
|       case mconn of | ||||
|         Nothing -> putStrLn "Content store not initialized for watched file processing." | ||||
|         Just conn -> do | ||||
|           forM_ asts $ \ast -> case ast of | ||||
|             SDef name [] body -> do | ||||
|               result <- evalAST (Just conn) selectedVersions body | ||||
|               hash <- ContentStore.storeTerm conn [name] result | ||||
|               putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash | ||||
|               putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm result | ||||
|             _ -> do | ||||
|               result <- evalAST (Just conn) selectedVersions ast | ||||
|               putStrLn $ "tricu > Result: " ++ formatT outputForm result | ||||
|           putStrLn $ "tricu > Processed file: " ++ filepath | ||||
|  | ||||
|           loop env form | ||||
|     formatTimestamp :: Integer -> String | ||||
|     formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts)) | ||||
|  | ||||
|     displayColoredHash :: T.Text -> IO () | ||||
|     displayColoredHash hash = do | ||||
|       let (prefix, rest) = T.splitAt 16 hash | ||||
|       setSGR [SetColor Foreground Vivid Cyan] | ||||
|       putStr $ T.unpack prefix | ||||
|       setSGR [SetColor Foreground Dull White] | ||||
|       putStr $ T.unpack rest | ||||
|       setSGR [Reset] | ||||
|  | ||||
|     coloredHashString :: T.Text -> String | ||||
|     coloredHashString hash =  | ||||
|       "\ESC[1;36m" ++ T.unpack (T.take 16 hash) ++  | ||||
|       "\ESC[0;37m" ++ T.unpack (T.drop 16 hash) ++  | ||||
|       "\ESC[0m" | ||||
|  | ||||
|     withColor :: ColorIntensity -> Color -> IO () -> IO () | ||||
|     withColor intensity color action = do | ||||
|       setSGR [SetColor Foreground intensity color] | ||||
|       action | ||||
|       setSGR [Reset] | ||||
|  | ||||
|     printColored :: ColorIntensity -> Color -> String -> IO () | ||||
|     printColored intensity color text = withColor intensity color $ putStr text | ||||
|  | ||||
|     printlnColored :: ColorIntensity -> Color -> String -> IO () | ||||
|     printlnColored intensity color text = withColor intensity color $ putStrLn text | ||||
|  | ||||
|     printSuccess :: String -> IO () | ||||
|     printSuccess = printlnColored Vivid Green | ||||
|  | ||||
|     printError :: String -> IO () | ||||
|     printError = printlnColored Vivid Red | ||||
|  | ||||
|     printWarning :: String -> IO () | ||||
|     printWarning = printlnColored Vivid Yellow | ||||
|  | ||||
|     printPrompt :: String -> IO () | ||||
|     printPrompt = printColored Vivid Blue | ||||
|  | ||||
|     printVariable :: String -> IO () | ||||
|     printVariable = printColored Vivid Magenta | ||||
|  | ||||
|     printTag :: String -> IO () | ||||
|     printTag = printColored Vivid Yellow | ||||
|  | ||||
|     printKeyword :: String -> IO () | ||||
|     printKeyword = printColored Vivid Blue | ||||
|  | ||||
|     printResult :: String -> IO () | ||||
|     printResult = printColored Dull White | ||||
|  | ||||
|     displayTags :: [T.Text] -> IO () | ||||
|     displayTags [] = return () | ||||
|     displayTags tags = do | ||||
|       putStr "    Tags: " | ||||
|       forM_ (zip [0..] tags) $ \(i, tag) -> do | ||||
|         printTag (T.unpack tag) | ||||
|         when (i < length tags - 1) $ putStr ", " | ||||
|       putStrLn "" | ||||
|  | ||||
| @ -14,7 +14,7 @@ data T = Leaf | Stem T | Fork T T | ||||
|  | ||||
| -- Abstract Syntax Tree for tricu | ||||
| data TricuAST | ||||
|   = SVar String | ||||
|   = SVar String (Maybe String)  -- Variable name and optional hash prefix | ||||
|   | SInt Integer | ||||
|   | SStr String | ||||
|   | SList [TricuAST] | ||||
| @ -30,11 +30,11 @@ data TricuAST | ||||
|  | ||||
| -- Lexer Tokens | ||||
| data LToken | ||||
|   = LKeywordT | ||||
|   | LIdentifier String | ||||
|   = LIdentifier String | ||||
|   | LIdentifierWithHash String String | ||||
|   | LKeywordT | ||||
|   | LNamespace String | ||||
|   | LIntegerLiteral Integer | ||||
|   | LStringLiteral String | ||||
|   | LImport String String | ||||
|   | LAssign | ||||
|   | LColon | ||||
|   | LDot | ||||
| @ -42,9 +42,10 @@ data LToken | ||||
|   | LCloseParen | ||||
|   | LOpenBracket | ||||
|   | LCloseBracket | ||||
|   | LStringLiteral String | ||||
|   | LIntegerLiteral Int | ||||
|   | LNewline | ||||
|   | LImport String String | ||||
|   deriving (Show, Eq, Ord) | ||||
|   deriving (Eq, Show, Ord) | ||||
|  | ||||
| -- Output formats | ||||
| data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode | ||||
| @ -54,7 +55,7 @@ data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode | ||||
| type Env = Map.Map String T | ||||
|  | ||||
| -- Tree Calculus Reduction Rules | ||||
| {-  | ||||
| {- | ||||
|   The t operator is left associative. | ||||
|   1.  t  t      a b       -> a | ||||
|   2.  t (t a)   b c       -> a c (b c) | ||||
|  | ||||
							
								
								
									
										13
									
								
								test/Spec.hs
									
									
									
									
									
								
							
							
						
						
									
										13
									
								
								test/Spec.hs
									
									
									
									
									
								
							| @ -12,7 +12,6 @@ import Control.Monad.IO.Class (liftIO) | ||||
| import Data.List              (isInfixOf) | ||||
| import Test.Tasty | ||||
| import Test.Tasty.HUnit | ||||
| import Test.Tasty.QuickCheck | ||||
| import Text.Megaparsec        (runParser) | ||||
|  | ||||
| import qualified Data.Map as Map | ||||
| @ -33,7 +32,7 @@ tests = testGroup "Tricu Tests" | ||||
|   , providedLibraries | ||||
|   , fileEval | ||||
|   , modules | ||||
|   , demos | ||||
| --  , demos | ||||
|   , decoding | ||||
|   ] | ||||
|  | ||||
| @ -103,7 +102,7 @@ parser = testGroup "Parser Tests" | ||||
|  | ||||
|   , testCase "Parse function definitions" $ do | ||||
|       let input = "x = (a b c : a)" | ||||
|           expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a")))) | ||||
|           expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a" Nothing)))) | ||||
|       parseSingle input @?= expect | ||||
|  | ||||
|   , testCase "Parse nested Tree Calculus terms" $ do | ||||
| @ -123,7 +122,7 @@ parser = testGroup "Parser Tests" | ||||
|  | ||||
|   , testCase "Parse function with applications" $ do | ||||
|       let input  = "f = (x : t x)" | ||||
|           expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x"))) | ||||
|           expect = SDef "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x" Nothing))) | ||||
|       parseSingle input @?= expect | ||||
|  | ||||
|   , testCase "Parse nested lists" $ do | ||||
| @ -170,17 +169,17 @@ parser = testGroup "Parser Tests" | ||||
|  | ||||
|   , testCase "Parse lambda abstractions" $ do | ||||
|       let input  = "(a : a)" | ||||
|           expect = (SLambda ["a"] (SVar "a")) | ||||
|           expect = (SLambda ["a"] (SVar "a" Nothing)) | ||||
|       parseSingle input @?= expect | ||||
|  | ||||
|   , testCase "Parse multiple arguments to lambda abstractions" $ do | ||||
|       let input  = "x = (a b : a)" | ||||
|           expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a"))) | ||||
|           expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a" Nothing))) | ||||
|       parseSingle input @?= expect | ||||
|  | ||||
|   , testCase "Grouping T terms with parentheses in function application" $ do | ||||
|       let input  = "x = (a : a)\nx (t)" | ||||
|           expect = [SDef "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf] | ||||
|           expect = [SDef "x" [] (SLambda ["a"] (SVar "a" Nothing)),SApp (SVar "x" Nothing) TLeaf] | ||||
|       parseTricu input @?= expect | ||||
|  | ||||
|   , testCase "Comments 1" $ do | ||||
|  | ||||
							
								
								
									
										31
									
								
								tricu.cabal
									
									
									
									
									
								
							
							
						
						
									
										31
									
								
								tricu.cabal
									
									
									
									
									
								
							| @ -1,7 +1,7 @@ | ||||
| cabal-version: 1.12 | ||||
|  | ||||
| name:           tricu | ||||
| version:        0.19.0 | ||||
| version:        1.0.0 | ||||
| description:    A micro-language for exploring Tree Calculus | ||||
| author:         James Eversole | ||||
| maintainer:     james@eversole.co | ||||
| @ -21,18 +21,32 @@ executable tricu | ||||
|       LambdaCase | ||||
|       MultiWayIf | ||||
|       OverloadedStrings | ||||
|       ScopedTypeVariables | ||||
|   ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC | ||||
|   build-depends: | ||||
|     base >=4.7 | ||||
|     , aeson | ||||
|     , ansi-terminal | ||||
|     , base64-bytestring | ||||
|     , bytestring | ||||
|     , cereal | ||||
|     , cmdargs | ||||
|     , containers | ||||
|     , cryptonite | ||||
|     , directory | ||||
|     , exceptions | ||||
|     , filepath | ||||
|     , fsnotify | ||||
|     , haskeline | ||||
|     , megaparsec | ||||
|     , mtl | ||||
|     , sqlite-simple | ||||
|     , tasty | ||||
|     , tasty-hunit | ||||
|     , text | ||||
|     , time | ||||
|     , transformers | ||||
|     , zlib | ||||
|   other-modules: | ||||
|     Eval | ||||
|     FileEval | ||||
| @ -51,20 +65,31 @@ test-suite tricu-tests | ||||
|       LambdaCase | ||||
|       MultiWayIf | ||||
|       OverloadedStrings | ||||
|       ScopedTypeVariables | ||||
|   build-depends:        | ||||
|     base | ||||
|     base >=4.7 | ||||
|     , aeson | ||||
|     , ansi-terminal | ||||
|     , base64-bytestring | ||||
|     , bytestring | ||||
|     , cereal | ||||
|     , cmdargs | ||||
|     , containers | ||||
|     , cryptonite | ||||
|     , directory | ||||
|     , exceptions | ||||
|     , filepath | ||||
|     , fsnotify | ||||
|     , haskeline | ||||
|     , megaparsec | ||||
|     , mtl | ||||
|     , sqlite-simple | ||||
|     , tasty | ||||
|     , tasty-hunit | ||||
|     , tasty-quickcheck | ||||
|     , text | ||||
|     , time | ||||
|     , transformers | ||||
|     , zlib | ||||
|   default-language:    Haskell2010 | ||||
|   other-modules: | ||||
|     Eval | ||||
|  | ||||
		Reference in New Issue
	
	Block a user