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*
|
||||
|
71
README.md
71
README.md
@ -2,22 +2,28 @@
|
||||
|
||||
## Introduction
|
||||
|
||||
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included to provide a useful programming tool.
|
||||
tricu (pronounced "tree-shoe") is a purely functional interpreted language implemented in Haskell. It is fundamentally based on the application of [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) terms, but minimal syntax sugar is included.
|
||||
|
||||
*tricu is under active development and you should expect breaking changes with every commit.*
|
||||
*This experiment has concluded. tricu will see no further development or bugfixes.*
|
||||
|
||||
tricu is the word for "tree" in Lojban: `(x1) is a tree of species/cultivar (x2)`.
|
||||
|
||||
## Acknowledgements
|
||||
|
||||
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog).
|
||||
|
||||
[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)
|
||||
- Simple module system for code organization
|
||||
- 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
|
||||
|
||||
@ -41,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/).
|
||||
@ -90,15 +111,3 @@ tricu decode [OPTIONS]
|
||||
-f --file=FILE Optional input file path to attempt decoding.
|
||||
Defaults to stdin.
|
||||
```
|
||||
|
||||
## Collaborating
|
||||
|
||||
I am happy to accept issue reports, pull requests, or questions about tricu [via email](mailto:james@eversole.co).
|
||||
|
||||
If you want to collaborate but don't want to email back-and-forth, please reach out via email once to let me know and I will provision a git.eversole.co account for you.
|
||||
|
||||
## Acknowledgements
|
||||
|
||||
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog).
|
||||
|
||||
[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.
|
||||
|
@ -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