James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ergonomic language features and lib cleanup

Browse Source 
+ let bindings
+ where bindings
+ do notation

I explored enough of the alternative language design space and decided
that we should commit fully to Lambda style. That means no more highly
tacit/concatenative point-free/partial programs as default. We'll keep
taking advantage of those capabilities when it makes sense, but the
library will continue to see massive overhauls.
This commit is contained in:
James Eversole
2026-05-22 18:23:13 -05:00
parent 7cea3d1559
commit 2e2db07bd6
17 changed files with 1039 additions and 589 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/ContentStore.hs
View File

@@ -9,6 +9,7 @@ import Data.List (nub, sort)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Database.SQLite.Simple
import System.IO (hPutStrLn, stderr)
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
import System.Environment (lookupEnv)
import System.Exit (die)
@@ -98,7 +99,9 @@ storeTerm conn newNamesStrList term = do
let termHashText = hashTerm term
newNamesTextList = map T.pack newNamesStrList
metadataText = T.pack "{}"
-- Store all Merkle nodes for this term
-- Store all Merkle nodes for this term. This traversal is where lazy T
-- values are forced into normalized Merkle nodes for persistence.
hPutStrLn stderr $ "[tricu] storing " ++ show newNamesStrList
_ <- storeMerkleNodes conn term
existingNamesQuery <- query conn
"SELECT names FROM terms WHERE hash = ?"

1
src/Eval.hs
View File

@@ -9,6 +9,7 @@ import Data.List (partition, (\\), elemIndex, foldl')
import Data.Map ()
import Data.Set (Set)
import Database.SQLite.Simple
import Debug.Trace (trace)
import qualified Data.Foldable as F ()
import qualified Data.Map as Map

32
src/Lexer.hs
View File

@@ -32,6 +32,7 @@ tricuLexer = do
where
tricuLexer' =
[ try lnewline
, try indentMarker
, try namespace
, try dot
, try identifierWithHash
@@ -45,15 +46,35 @@ tricuLexer = do
, closeParen
, openBracket
, closeBracket
, try bindArrow
, try arrowLeft
, try arrowRight
]
lexTricu :: String -> [LToken]
lexTricu input = case runParser tricuLexer "" input of
lexTricu input = case runParser tricuLexer "" (insertIndentMarkers input) of
Left err -> errorWithoutStackTrace $ "Lexical error:\n" ++ errorBundlePretty err
Right toks -> toks
insertIndentMarkers :: String -> String
insertIndentMarkers = go False False
where
marker n = '\v' : show n ++ " "
go _ _ [] = []
go inString escaped (c:cs)
| inString =
c : go (not (c == '"' && not escaped)) (c == '\\' && not escaped) cs
| c == '"' = c : go True False cs
| c == '\n' =
let (spaces, rest) = span (== ' ') cs
n = length spaces
in if n == 0
then '\n' : go False False rest
else '\n' : marker n ++ go False False rest
| c == '\t' = errorWithoutStackTrace "Tabs are not allowed for indentation; use two spaces per indent level"
| otherwise = c : go False False cs
keywordT :: Lexer LToken
keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT
@@ -136,9 +157,18 @@ arrowLeft = string "<|" $> LArrowLeft
arrowRight :: Lexer LToken
arrowRight = string "|>" $> LArrowRight
bindArrow :: Lexer LToken
bindArrow = string "<-" $> LBindArrow
lnewline :: Lexer LToken
lnewline = char '\n' $> LNewline
indentMarker :: Lexer LToken
indentMarker = do
void (char '\v')
n <- some digitChar
pure (LIndent (read n))
sc :: Lexer ()
sc = space
(void $ takeWhile1P (Just "space") (\c -> c == ' ' || c == '\t'))

6
src/Main.hs
View File

@@ -74,7 +74,9 @@ readEvaluatedForm = eitherReader $ \s -> case s of
"ternary" -> Right Ternary
"ascii" -> Right Ascii
"decode" -> Right Decode
_ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode"
"number" -> Right Number
"string" -> Right StringLit
_ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode, number, string"
evalParser :: Parser TricuArgs
evalParser = Eval
@@ -84,7 +86,7 @@ evalParser = Eval
<> short 'f'
<> metavar "FORM"
<> value Tree
<> help "Output format: tree, fsl, ast, ternary, ascii, decode"
<> help "Output format: tree, fsl, ast, ternary, ascii, decode, number, string"
)
<*> option str
( long "output"

288
src/Parser.hs
View File

@@ -16,7 +16,7 @@ data Context = Top | Nested
deriving (Eq, Show)
reservedNames :: Set.Set String
reservedNames = Set.fromList ["t", "!result"]
reservedNames = Set.fromList ["t", "!result", "let", "in", "where", "do"]
parseTricu :: String -> [TricuAST]
parseTricu input =
@@ -69,17 +69,26 @@ manyItemsP = do
topItemP :: TokParser TricuAST
topItemP = do
toks <- getInput
case toks of
LIdentifier _ : LAssign : _ -> definitionP
_ -> exprTopP
case definitionHeadTop toks of
Just _ -> definitionP
Nothing -> exprTopP
definitionHeadTop :: [LToken] -> Maybe (String, [String])
definitionHeadTop toks =
case collectIdentifiersNoNewlines toks of
(name:args, LAssign : _)
| name `Set.notMember` reservedNames
, all (`Set.notMember` reservedNames) args -> Just (name, args)
_ -> Nothing
definitionP :: TokParser TricuAST
definitionP = do
name <- identifierNameP
args <- many identifierNameP
void (tok (== LAssign) "=")
skipNestedNewlines
body <- exprTopP
pure (SDef name [] body)
bodyIndent <- skipNestedNewlinesGetIndent
body <- exprAtIndentP bodyIndent
pure (SDef name args body)
importP :: TokParser TricuAST
importP = do
@@ -96,7 +105,7 @@ exprTopP = do
toks <- getInput
case lambdaHeadTop toks of
Just params -> lambdaP Top params
Nothing -> pipeTopP
Nothing -> whereChainP pipeTopP
exprNestedP :: TokParser TricuAST
exprNestedP = do
@@ -104,7 +113,14 @@ exprNestedP = do
toks <- getInput
case lambdaHeadNested toks of
Just params -> lambdaP Nested params
Nothing -> pipeNestedP
Nothing -> whereChainP pipeNestedP
exprAtIndentP :: Int -> TokParser TricuAST
exprAtIndentP n = do
toks <- getInput
case lambdaHeadTop toks of
Just params -> lambdaP Top params
Nothing -> whereChainP (pipeAtIndentP n)
lambdaP :: Context -> [String] -> TokParser TricuAST
lambdaP ctx params = do
@@ -174,7 +190,11 @@ applyPipe acc (PipeForward, rhs) =
pipeTopP :: TokParser TricuAST
pipeTopP =
pipeChainP appTopP appNestedP
pipeAtIndentP 0
pipeAtIndentP :: Int -> TokParser TricuAST
pipeAtIndentP n =
pipeChainP (appAtIndentP n) appNestedP
pipeNestedP :: TokParser TricuAST
pipeNestedP =
@@ -199,18 +219,52 @@ pipeOpP =
<|> (tok (== LArrowRight) "|>" *> pure PipeForward)
appTopP :: TokParser TricuAST
appTopP = do
first <- atomTopP
appRestTopP first
appTopP = appAtIndentP 0
appRestTopP :: TricuAST -> TokParser TricuAST
appRestTopP acc = do
mt <- peekP
case mt of
Just t | startsAtom t -> do
appAtIndentP :: Int -> TokParser TricuAST
appAtIndentP n = do
first <- atomTopP
appRestAtIndentP n first
appRestAtIndentP :: Int -> TricuAST -> TokParser TricuAST
appRestAtIndentP currentIndent acc = do
toks <- getInput
let shouldContinue = case toks of
LNewline : LIndent n : rest
| currentIndent > 0
, n > currentIndent
, not (isIndentedTerminator rest)
, Just t <- firstNonLayout rest -> startsAtom t && not (isExprTerminator t)
_ -> False
if shouldContinue
then do
indentedNewlineP
arg <- atomTopP
appRestTopP (SApp acc arg)
_ -> pure acc
appRestAtIndentP currentIndent (SApp acc arg)
else do
mt <- peekP
case mt of
Just t | startsAtom t && not (isExprTerminator t) -> do
arg <- atomTopP
appRestAtIndentP currentIndent (SApp acc arg)
_ -> pure acc
isIndentedTerminator :: [LToken] -> Bool
isIndentedTerminator toks =
case dropLayout toks of
LIdentifier "where" : _ -> True
rest -> definitionHeadTop rest /= Nothing
firstNonLayout :: [LToken] -> Maybe LToken
firstNonLayout toks =
case dropLayout toks of
[] -> Nothing
x : _ -> Just x
dropLayout :: [LToken] -> [LToken]
dropLayout (LNewline : rest) = dropLayout rest
dropLayout (LIndent _ : rest) = dropLayout rest
dropLayout rest = rest
appNestedP :: TokParser TricuAST
appNestedP = do
@@ -222,7 +276,7 @@ appRestNestedP acc = do
skipNestedNewlines
mt <- peekP
case mt of
Just t | startsAtom t -> do
Just t | startsAtom t && not (isExprTerminator t) -> do
arg <- atomNestedP
appRestNestedP (SApp acc arg)
_ -> pure acc
@@ -238,19 +292,28 @@ startsAtom (LIntegerLiteral _) = True
startsAtom (LStringLiteral _) = True
startsAtom _ = False
isExprTerminator :: LToken -> Bool
isExprTerminator (LIdentifier "in") = True
isExprTerminator (LIdentifier "where") = True
isExprTerminator _ = False
atomTopP :: TokParser TricuAST
atomTopP = do
toks <- getInput
case toks of
LOpenParen : _ -> groupedP
LOpenBracket : _ -> listP
LNamespace _ : LDot : _ -> namespacedVarP
LIdentifier _ : _ -> plainVarP
LIdentifierWithHash _ _ : _ -> plainVarP
LKeywordT : _ -> leafP
LIntegerLiteral _ : _ -> intP
LStringLiteral _ : _ -> strP
_ -> fail "expected expression atom"
LOpenParen : _ -> groupedP
LOpenBracket : _ -> listP
LNamespace _ : LDot : _ -> namespacedVarP
LIdentifier "let" : _ -> letP
LIdentifier "do" : _ -> doP
LIdentifier name : _
| name == "in" || name == "where" -> fail ("unexpected reserved word: " ++ name)
| otherwise -> plainVarP
LIdentifierWithHash _ _ : _ -> plainVarP
LKeywordT : _ -> leafP
LIntegerLiteral _ : _ -> intP
LStringLiteral _ : _ -> strP
_ -> fail "expected expression atom"
atomNestedP :: TokParser TricuAST
atomNestedP = skipNestedNewlines *> atomTopP
@@ -289,15 +352,118 @@ listElementP :: TokParser TricuAST
listElementP = do
toks <- getInput
case toks of
LOpenParen : _ -> groupedP
LOpenBracket : _ -> listP
LNamespace _ : LDot : _ -> namespacedVarP
LIdentifier _ : _ -> plainVarP
LIdentifierWithHash _ _ : _ -> plainVarP
LKeywordT : _ -> leafP
LIntegerLiteral _ : _ -> intP
LStringLiteral _ : _ -> strP
_ -> fail "expected list element"
LOpenParen : _ -> groupedP
LOpenBracket : _ -> listP
LNamespace _ : LDot : _ -> namespacedVarP
LIdentifier "let" : _ -> letP
LIdentifier "do" : _ -> doP
LIdentifier name : _
| name == "in" || name == "where" -> fail ("unexpected reserved word: " ++ name)
| otherwise -> plainVarP
LIdentifierWithHash _ _ : _ -> plainVarP
LKeywordT : _ -> leafP
LIntegerLiteral _ : _ -> intP
LStringLiteral _ : _ -> strP
_ -> fail "expected list element"
whereChainP :: TokParser TricuAST -> TokParser TricuAST
whereChainP parseBody = do
body <- parseBody
mWhere <- optional (try whereBindingP)
case mWhere of
Nothing -> pure body
Just (name, args, value) ->
let boundValue = foldr (\p acc -> SLambda [p] acc) value args
in pure (SApp (SLambda [name] body) boundValue)
whereBindingP :: TokParser (String, [String], TricuAST)
whereBindingP = do
skipNestedNewlines
void (keywordIdentifierP "where")
skipNestedNewlines
name <- identifierNameP
args <- many identifierNameP
void (tok (== LAssign) "=")
valueIndent <- skipNestedNewlinesGetIndent
value <- exprAtIndentP valueIndent
pure (name, args, value)
letP :: TokParser TricuAST
letP = do
void (keywordIdentifierP "let")
skipNestedNewlines
name <- identifierNameP
args <- many identifierNameP
void (tok (== LAssign) "=")
valueIndent <- skipNestedNewlinesGetIndent
value <- exprAtIndentP valueIndent
skipNestedNewlines
void (keywordIdentifierP "in")
bodyIndent <- skipNestedNewlinesGetIndent
body <- exprAtIndentP bodyIndent
let boundValue = foldr (\p acc -> SLambda [p] acc) value args
pure (SApp (SLambda [name] body) boundValue)
data DoStmt
= DoBind String TricuAST
| DoExpr TricuAST
deriving (Eq, Show)
doP :: TokParser TricuAST
doP = do
void (keywordIdentifierP "do")
skipNestedNewlines
bindOp <- atomTopP
blockIndent <- requireIndentedBlockP
stmts <- doBlockP blockIndent
lowerDo bindOp stmts
doBlockP :: Int -> TokParser [DoStmt]
doBlockP blockIndent = do
first <- doStmtP blockIndent
rest <- many (try (sameIndentP blockIndent *> doStmtP blockIndent))
pure (first : rest)
doStmtP :: Int -> TokParser DoStmt
doStmtP blockIndent = do
toks <- getInput
case toks of
LIdentifier name : LBindArrow : _ -> do
void identifierNameP
void (tok (== LBindArrow) "<-")
exprIndent <- skipNestedNewlinesGetIndent
DoBind name <$> exprAtIndentP (max blockIndent exprIndent)
_ -> DoExpr <$> exprAtIndentP blockIndent
lowerDo :: TricuAST -> [DoStmt] -> TokParser TricuAST
lowerDo _ [] = fail "do block must contain at least one statement"
lowerDo _ [DoExpr expr] = pure expr
lowerDo bindOp [DoBind _ _] = fail "last do statement must be an expression"
lowerDo bindOp (DoBind name action : rest) = do
body <- lowerDo bindOp rest
pure (SApp (SApp bindOp action) (SLambda [name] body))
lowerDo bindOp (DoExpr action : rest) = do
body <- lowerDo bindOp rest
pure (SApp (SApp bindOp action) (SLambda ["_"] body))
requireIndentedBlockP :: TokParser Int
requireIndentedBlockP = do
void (tok (== LNewline) "newline")
t <- tok isIndent "indent"
case t of
LIndent n | n > 0 -> pure n
_ -> fail "expected indented do block"
sameIndentP :: Int -> TokParser ()
sameIndentP n = do
void (tok (== LNewline) "newline")
t <- tok isIndent "indent"
case t of
LIndent m | m == n -> pure ()
_ -> fail "expected do statement at same indentation"
keywordIdentifierP :: String -> TokParser LToken
keywordIdentifierP name = tok (== LIdentifier name) name
leafP :: TokParser TricuAST
leafP = tok (== LKeywordT) "t" *> pure TLeaf
@@ -381,14 +547,50 @@ atEndP :: TokParser Bool
atEndP = null <$> getInput
skipTopNewlines :: TokParser ()
skipTopNewlines = skipMany (tok (== LNewline) "newline")
skipTopNewlines = skipMany newlineWithOptionalIndentP
skipNestedNewlines :: TokParser ()
skipNestedNewlines = skipMany (tok (== LNewline) "newline")
skipNestedNewlines = void skipNestedNewlinesGetIndent
skipNestedNewlinesGetIndent :: TokParser Int
skipNestedNewlinesGetIndent = go 0
where
go lastIndent = do
mt <- optional (try newlineWithOptionalIndentValueP)
case mt of
Nothing -> pure lastIndent
Just n -> go n
newlineWithOptionalIndentP :: TokParser ()
newlineWithOptionalIndentP = void newlineWithOptionalIndentValueP
newlineWithOptionalIndentValueP :: TokParser Int
newlineWithOptionalIndentValueP = do
void (tok (== LNewline) "newline")
mt <- optional indentP
pure $ case mt of
Just (LIndent n) -> n
_ -> 0
indentedNewlineP :: TokParser ()
indentedNewlineP = do
void (tok (== LNewline) "newline")
t <- tok isIndent "indent"
case t of
LIndent n | n > 0 -> pure ()
_ -> fail "expected indented continuation"
indentP :: TokParser LToken
indentP = tok isIndent "indent"
isIndent :: LToken -> Bool
isIndent (LIndent _) = True
isIndent _ = False
dropNewlines :: [LToken] -> [LToken]
dropNewlines (LNewline : rest) = dropNewlines rest
dropNewlines rest = rest
dropNewlines (LNewline : LIndent _ : rest) = dropNewlines rest
dropNewlines (LNewline : rest) = dropNewlines rest
dropNewlines rest = rest
handleParseError :: [LToken] -> ParseErrorBundle [LToken] Void -> String
handleParseError toks bundle =

6
src/REPL.hs
View File

@@ -130,15 +130,15 @@ repl = do
handleOutput :: REPLState -> InputT IO ()
handleOutput state = do
let formats = [Decode, Tree, FSL, AST, Ternary, Ascii]
let formats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
outputStrLn "Available output formats:"
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
(zip [1..] formats)
evalResult <- runMaybeT $ do
input <- MaybeT $ getInputLine "Select output format (1-6) < "
input <- MaybeT $ getInputLine "Select output format (1-8) < "
case reads input of
[(n, "")] | n >= 1 && n <= 6 ->
[(n, "")] | n >= 1 && n <= 8 ->
return $ formats !! (n-1)
_ -> MaybeT $ return Nothing

6
src/Research.hs
View File

@@ -51,11 +51,13 @@ data LToken
| LIntegerLiteral Int
| LArrowLeft
| LArrowRight
| LBindArrow
| LNewline
| LIndent Int
deriving (Eq, Show, Ord)
-- Output formats
data EvaluatedForm = Tree | FSL | AST | Ternary | Ascii | Decode
data EvaluatedForm = Tree | FSL | AST | Ternary | Ascii | Decode | Number | StringLit
deriving (Show)
-- Environment containing previously evaluated TC terms
@@ -257,6 +259,8 @@ formatT AST = show . toAST
formatT Ternary = toTernaryString
formatT Ascii = toAscii
formatT Decode = decodeResult
formatT Number = either (\e -> "<not-number: " ++ e ++ ">") show . toNumber
formatT StringLit = either (\e -> "<not-string: " ++ e ++ ">") show . toString
toSimpleT :: String -> String
toSimpleT s = T.unpack