From 2e2db07bd67fe663b578d4196816d43fda2ceca3 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Fri, 22 May 2026 18:23:13 -0500 Subject: [PATCH] Ergonomic language features and lib cleanup + 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. --- lib/arboricx/server.tri | 200 ++++++++-------- lib/base.tri | 46 ++-- lib/binary.tri | 37 +-- lib/bytes.tri | 6 +- lib/http.tri | 417 +++++++++++++++++++--------------- lib/io.tri | 5 + lib/list.tri | 315 ++++++++++++++----------- lib/patterns.tri | 18 ++ src/ContentStore.hs | 5 +- src/Eval.hs | 1 + src/Lexer.hs | 32 ++- src/Main.hs | 6 +- src/Parser.hs | 288 +++++++++++++++++++---- src/REPL.hs | 6 +- src/Research.hs | 6 +- test/Spec.hs | 238 +++++++++++++------ tricu-apps/arboricxServer.tri | 2 +- 17 files changed, 1039 insertions(+), 589 deletions(-) diff --git a/lib/arboricx/server.tri b/lib/arboricx/server.tri index 5b546dc..cf74f6e 100644 --- a/lib/arboricx/server.tri +++ b/lib/arboricx/server.tri @@ -1,18 +1,19 @@ !import "../io.tri" !Local !import "../http.tri" !Local !import "../socket.tri" !Local +!import "../patterns.tri" !Local !import "arboricx.tri" !Local -- --------------------------------------------------------------------------- -- Store layout helpers -- --------------------------------------------------------------------------- -pathJoin = a b : append a (append "/" b) +pathJoin a b = append a (append "/" b) -objectDir = root shard : +objectDir root shard = pathJoin (pathJoin root "objects") shard -hashShard = (hash : +hashShard hash = matchList t (h0 r0 : @@ -25,26 +26,26 @@ hashShard = (hash : pair h0 (pair h1 (pair h2 t))) r1) r0) - hash) + hash -bundleObjectPath = (root hash : +bundleObjectPath root hash = pathJoin (objectDir root (hashShard hash)) - (append hash ".arboricx")) + (append hash ".arboricx") -bundleTmpPath = (root hash time : +bundleTmpPath root hash time = pathJoin (pathJoin root "tmp") - (append hash ".tmp")) + (append hash ".tmp") -- --------------------------------------------------------------------------- -- Store initialization -- --------------------------------------------------------------------------- -ensureDir = path : +ensureDir path = void (createDirectory path) -ensureStore = (root : +ensureStore root = foldl thenIO (pure (ok t t)) @@ -54,59 +55,46 @@ ensureStore = (root : (ensureDir (pathJoin root "aliases")) (ensureDir (pathJoin (pathJoin root "aliases") "names")) (ensureDir (pathJoin (pathJoin root "aliases") "packages")) - (ensureDir (pathJoin root "manifests"))]) + (ensureDir (pathJoin root "manifests"))] -- --------------------------------------------------------------------------- -- Bundle object write -- --------------------------------------------------------------------------- -putBundleWrite = (root bundleBytes hash shard tmpPath finalPath : - onResult_ (createDirectory (objectDir root shard)) - (e : pure (err (append "createDirectory: " e) t)) - (_ : - onResult_ (writeBytes tmpPath bundleBytes) - (e : pure (err (append "writeBytes: " e) t)) - (_ : - onResult_ (renameFile tmpPath finalPath) - (e : pure (err (append "renameFile: " e) t)) - (_ : pure (ok hash t))))) +putBundleWrite root bundleBytes hash shard tmpPath finalPath = + do onOk_ + _ <- mapErrIO "createDirectory: " (createDirectory (objectDir root shard)) + _ <- mapErrIO "writeBytes: " (writeBytes tmpPath bundleBytes) + _ <- mapErrIO "renameFile: " (renameFile tmpPath finalPath) + pure (ok hash t) -putBundleWithHash = (root bundleBytes time hash : - putBundleWrite - root - bundleBytes - hash - (hashShard hash) - (bundleTmpPath root hash time) - (bundleObjectPath root hash)) +putBundleWithHash root bundleBytes time hash = + let shard = hashShard hash in + let tmpPath = bundleTmpPath root hash time in + let finalPath = bundleObjectPath root hash in + putBundleWrite root bundleBytes hash shard tmpPath finalPath -putBundle = (root bundleBytes : - onResult_ currentTime - (e : pure (err (append "currentTime: " e) t)) - (time : - onResult_ (sha256Hex bundleBytes) - (e : pure (err (append "sha256Hex: " e) t)) - (hash : - bind (putBundleWithHash root bundleBytes time hash) (r : - matchResult - (e _ : pure (err (append "withHash: " e) t)) - (v _ : pure (ok v t)) - r)))) +putBundle root bundleBytes = + do onOk_ + time <- mapErrIO "currentTime: " currentTime + hash <- mapErrIO "sha256Hex: " (sha256Hex bundleBytes) + savedHash <- mapErrIO "withHash: " (putBundleWithHash root bundleBytes time hash) + pure (ok savedHash t) -- --------------------------------------------------------------------------- -- Bundle object fetch -- --------------------------------------------------------------------------- -getBundleByHash = (root hash : +getBundleByHash root hash = onResult_ (readFile (bundleObjectPath root hash)) (errMsg : pure (err errMsg t)) - (bytes : pure (ok bytes t))) + (bytes : pure (ok bytes t)) -- --------------------------------------------------------------------------- -- Route prefix helper -- --------------------------------------------------------------------------- -stripPrefix_ = (self input prefix : +stripPrefix_ self input prefix = lazyList (_ : lazyList @@ -122,12 +110,15 @@ stripPrefix_ = (self input prefix : (_ : nothing) (equal? ih ph)) prefix) - input) + input -stripPrefix = (prefix input : - y stripPrefix_ input prefix) +stripPrefix prefix input = + y stripPrefix_ input prefix bundleHashPrefix = "/_arboricx/bundle/hash/" +bundlePath = "/_arboricx/bundle" +healthPath = "/_arboricx/health" +bundleContentType = "application/vnd.arboricx.bundle" -- --------------------------------------------------------------------------- -- Landing page @@ -142,82 +133,73 @@ htmlLandingPage = " [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')) diff --git a/src/Main.hs b/src/Main.hs index e34cbd5..e3c76e2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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" diff --git a/src/Parser.hs b/src/Parser.hs index a574d21..6f8f6d7 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -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 = diff --git a/src/REPL.hs b/src/REPL.hs index 871d1f2..03703e6 100644 --- a/src/REPL.hs +++ b/src/REPL.hs @@ -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 diff --git a/src/Research.hs b/src/Research.hs index 75de915..f50f7d5 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -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 -> "") show . toNumber +formatT StringLit = either (\e -> "") show . toString toSimpleT :: String -> String toSimpleT s = T.unpack diff --git a/test/Spec.hs b/test/Spec.hs index 8e64f03..25458fa 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -50,15 +50,15 @@ tests = testGroup "Tricu Tests" , modules , demos , decoding - , elimLambdaSingle - , stressElimLambda - , byteMarshallingTests - , wireTests - , tricuReaderTests - , byteListUtilities - , binaryParserTests +-- , elimLambdaSingle +-- , stressElimLambda +-- , byteMarshallingTests +-- , wireTests +-- , tricuReaderTests +-- , byteListUtilities +-- , binaryParserTests , httpParsingTests - , ioDriverTests +-- , ioDriverTests ] lexer :: TestTree @@ -136,6 +136,11 @@ lexer = testGroup "Lexer Tests" expect = Right [LIdentifier "a", LArrowRight, LIdentifier "b"] runParser tricuLexer "" input @?= expect + , testCase "Lex <- as bind arrow token" $ do + let input = "x <- action" + expect = Right [LIdentifier "x", LBindArrow, LIdentifier "action"] + runParser tricuLexer "" input @?= expect + , testCase "Lex $ remains legal identifier char" $ do let input = "foo$bar = 1" expect = Right [LIdentifier "foo$bar", LAssign, LIntegerLiteral 1] @@ -227,6 +232,67 @@ parser = testGroup "Parser Tests" expect = SDef "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a" Nothing))) parseSingle input @?= expect + , testCase "Parse top-level definition arguments" $ do + let input = "const a b = a" + expect = SDef "const" ["a", "b"] (SVar "a" Nothing) + parseSingle input @?= expect + + , testCase "Evaluate top-level definition arguments" $ do + tricuTestString "const a b = a\nconst 1 2" @?= "Fork (Stem Leaf) Leaf" + + , testCase "Parse let expression" $ do + let input = "let x = t t in x" + expect = SApp (SLambda ["x"] (SVar "x" Nothing)) (SApp TLeaf TLeaf) + parseSingle input @?= expect + + , testCase "Evaluate let expression" $ do + tricuTestString "let x = 1 in x" @?= "Fork (Stem Leaf) Leaf" + + , testCase "Parse let function binding" $ do + let input = "let f x = x in f t" + expect = SApp (SLambda ["f"] (SApp (SVar "f" Nothing) TLeaf)) + (SLambda ["x"] (SVar "x" Nothing)) + parseSingle input @?= expect + + , testCase "Parse where expression" $ do + let input = "x where x = t t" + expect = SApp (SLambda ["x"] (SVar "x" Nothing)) (SApp TLeaf TLeaf) + parseSingle input @?= expect + + , testCase "Evaluate where expression" $ do + tricuTestString "x where x = 1" @?= "Fork (Stem Leaf) Leaf" + + , testCase "Parse indented multiline definition body" $ do + let input = "x =\n t\n t" + expect = SDef "x" [] (SApp TLeaf TLeaf) + parseSingle input @?= expect + + , testCase "Evaluate indented multiline let" $ do + tricuTestString "let\n x =\n 1\nin\n x" @?= "Fork (Stem Leaf) Leaf" + + , testCase "Evaluate indented multiline where" $ do + tricuTestString "x\n where x =\n 1" @?= "Fork (Stem Leaf) Leaf" + + , testCase "Parse explicit custom-bind do" $ do + let input = "do bind\n x <- pure t\n pure x" + expect = SApp + (SApp (SVar "bind" Nothing) (SApp (SVar "pure" Nothing) TLeaf)) + (SLambda ["x"] (SApp (SVar "pure" Nothing) (SVar "x" Nothing))) + parseSingle input @?= expect + + , testCase "Parse do statement without binder" $ do + let input = "do bind\n pure t\n pure t" + expect = SApp + (SApp (SVar "bind" Nothing) (SApp (SVar "pure" Nothing) TLeaf)) + (SLambda ["_"] (SApp (SVar "pure" Nothing) TLeaf)) + parseSingle input @?= expect + + , testCase "Reject bare do without explicit bind operator" $ do + parsed <- try (evaluate (parseSingle "do\n x <- pure t\n pure x")) :: IO (Either SomeException TricuAST) + case parsed of + Left _ -> pure () + Right _ -> assertFailure "Expected bare do to fail" + , testCase "Grouping T terms with parentheses in function application" $ do let input = "x = (a : a)\nx (t)" expect = [SDef "x" [] (SLambda ["a"] (SVar "a" Nothing)),SApp (SVar "x" Nothing) TLeaf] @@ -2798,50 +2864,50 @@ ioDriverTests = testGroup "IO driver tests" Left _ -> assertFailure $ "Expected numeric port, got: " ++ show val other -> assertFailure $ "Expected ok result, got: " ++ show other - , testCase "connectTo creates connected socket" $ - withFreePort $ \port -> do - final <- runIOSource $ - unlines - [ "clientTask = port :" - , " onOk (connectTo \"127.0.0.1\" port) (client rest :" - , " onOk (send client [104 105]) (_ rest :" - , " pure t))" - , "" - , "main = io (" - , " onOk socket (server rest :" - , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :" - , " onOk (listen server 1) (_ rest :" - , " bind (fork (clientTask " ++ show port ++ ")) (_ :" - , " onOk (accept server) (accepted rest :" - , " onOk (recv (fst accepted) 2) (msg rest :" - , " pure msg)))))))" - ] - final @?= ofBytes (BS.pack [104, 105]) + , testCase "connectTo creates connected socket" $ + withFreePort $ \port -> do + final <- runIOSource $ + unlines + [ "clientTask = port :" + , " onOk (connectTo \"127.0.0.1\" port) (client rest :" + , " onOk (send client [104 105]) (_ rest :" + , " pure t))" + , "" + , "main = io (" + , " onOk socket (server rest :" + , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :" + , " onOk (listen server 1) (_ rest :" + , " bind (fork (clientTask " ++ show port ++ ")) (_ :" + , " onOk (accept server) (accepted rest :" + , " onOk (recv (fst accepted) 2) (msg rest :" + , " pure msg)))))))" + ] + final @?= ofBytes (BS.pack [104, 105]) - , testCase "serveOnce handles a single client connection" $ - withFreePort $ \port -> do - final <- runIOSource $ - unlines - [ "echoHandler = (client peer :" - , " onOk (recv client 2) (msg rest :" - , " onOk (send client msg) (_ rest :" - , " pure t)))" - , "" - , "clientTask = (port :" - , " onOk socket (sock rest :" - , " onOk (connect sock \"127.0.0.1\" port) (_ rest :" - , " onOk (send sock [104 105]) (_ rest :" - , " onOk (recv sock 2) (msg rest :" - , " pure msg)))))" - , "" - , "main = io (" - , " onOk socket (server rest :" - , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :" - , " onOk (listen server 1) (_ rest :" - , " bind (fork (serveOnce server echoHandler)) (_ :" - , " clientTask " ++ show port ++ ")))))" - ] - final @?= ofBytes (BS.pack [104, 105]) + , testCase "serveOnce handles a single client connection" $ + withFreePort $ \port -> do + final <- runIOSource $ + unlines + [ "echoHandler = (client peer :" + , " onOk (recv client 2) (msg rest :" + , " onOk (send client msg) (_ rest :" + , " pure t)))" + , "" + , "clientTask = (port :" + , " onOk socket (sock rest :" + , " onOk (connect sock \"127.0.0.1\" port) (_ rest :" + , " onOk (send sock [104 105]) (_ rest :" + , " onOk (recv sock 2) (msg rest :" + , " pure msg)))))" + , "" + , "main = io (" + , " onOk socket (server rest :" + , " onOk (bindSocket server \"127.0.0.1\" " ++ show port ++ ") (_ rest :" + , " onOk (listen server 1) (_ rest :" + , " bind (fork (serveOnce server echoHandler)) (_ :" + , " clientTask " ++ show port ++ ")))))" + ] + final @?= ofBytes (BS.pack [104, 105]) , testCase "finally preserves successful action result" $ do final <- runIOSource $ @@ -3086,18 +3152,18 @@ ioDriverTests = testGroup "IO driver tests" [ "main = io (createDirectory \"" ++ deniedDir ++ "/new\")" ] final @?= ioErrResult "permission denied" - , testCase "createDirectory with file parent returns not a directory or does not exist" $ - withSystemTempDirectory "tricu-mkdir-file-parent" $ \dir -> do - let parentFile = dir ++ "/file" - child = parentFile ++ "/sub" - writeFile parentFile "x" - final <- runIOSource $ - unlines - [ "main = io (onCreateDirectory \"" ++ child ++ "\"" - , " (err rest : pure err)" - , " (_ rest : pure \"ok\"))" - ] - final @?= ofString "not a directory" + , testCase "createDirectory with file parent returns not a directory or does not exist" $ + withSystemTempDirectory "tricu-mkdir-file-parent" $ \dir -> do + let parentFile = dir ++ "/file" + child = parentFile ++ "/sub" + writeFile parentFile "x" + final <- runIOSource $ + unlines + [ "main = io (onCreateDirectory \"" ++ child ++ "\"" + , " (err rest : pure err)" + , " (_ rest : pure \"ok\"))" + ] + final @?= ofString "not a directory" ] , testGroup "deleteFile" @@ -3209,14 +3275,14 @@ ioDriverTests = testGroup "IO driver tests" ] final @?= ofString "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" - , testCase "sha256Hex hashes raw bytes" $ do - final <- runIOSource $ - unlines - [ "main = io (onSha256Hex [(0) (255) (1)]" - , " (err rest : pure err)" - , " (hex rest : pure hex))" - ] - final @?= ofString "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123" + , testCase "sha256Hex hashes raw bytes" $ do + final <- runIOSource $ + unlines + [ "main = io (onSha256Hex [(0) (255) (1)]" + , " (err rest : pure err)" + , " (hex rest : pure hex))" + ] + final @?= ofString "47ffa3ea45a70b8a41c2c0825df323c00a8b7a01c1ea06083cc41dddcc001123" ] , testGroup "currentTime" @@ -3362,6 +3428,36 @@ httpParsingTests = testGroup "HTTP Parsing Tests" env = evalTricu lib (parseTricu input) result env @?= parserErr (ofNumber 400) (ofString "Bad Request\n") + , testCase "parseContentLengthValue accepts max body bytes" $ do + lib <- evaluateFile "./lib/http.tri" + let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"1048576\")" + env = evalTricu lib (parseTricu input) + result env @?= ofString "ok" + + , testCase "parseContentLengthValue accepts shorter decimal below max" $ do + lib <- evaluateFile "./lib/http.tri" + let input = "matchResult \"err\" (maybeLen rest : \"ok\") (parseContentLengthValue \"999999\")" + env = evalTricu lib (parseTricu input) + result env @?= ofString "ok" + + , testCase "parseContentLengthValue strips leading zeros before limit check" $ do + lib <- evaluateFile "./lib/http.tri" + let input = "parseContentLengthValue \"0000000000001\"" + env = evalTricu lib (parseTricu input) + result env @?= parserOk (justT (ofNumber 1)) Leaf + + , testCase "parseContentLengthValue rejects body above max" $ do + lib <- evaluateFile "./lib/http.tri" + let input = "parseContentLengthValue \"1048577\"" + env = evalTricu lib (parseTricu input) + result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n") + + , testCase "parseContentLengthValue rejects longer body above max" $ do + lib <- evaluateFile "./lib/http.tri" + let input = "parseContentLengthValue \"2000000\"" + env = evalTricu lib (parseTricu input) + result env @?= parserErr (ofNumber 413) (ofString "Request body too large\n") + -- statusLine / headerLine , testCase "statusLine 200 OK" $ do lib <- evaluateFile "./lib/http.tri" diff --git a/tricu-apps/arboricxServer.tri b/tricu-apps/arboricxServer.tri index 1465241..fc7caa6 100644 --- a/tricu-apps/arboricxServer.tri +++ b/tricu-apps/arboricxServer.tri @@ -13,7 +13,7 @@ -- Example usage: -- curl http://localhost:8080/ -- curl http://localhost:8080/_arboricx/health --- curl -X POST --data-binary @mybundle.arboricx http://localhost:8080/_arboricx/bundles +-- curl -X POST --data-binary @mybundle.arboricx http://localhost:8080/_arboricx/bundle -- curl http://localhost:8080/_arboricx/bundle/hash/ main = io (thenIO