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

General refactor for legibility

Browse Source 
Priming to update all source to lhs and document extensively
This commit is contained in:
James Eversole
2025-01-19 14:41:25 -06:00
parent a3282b794f
commit ad02c8b86a
6 changed files with 127 additions and 171 deletions
Download Patch File Download Diff File Expand all files Collapse all files

163
src/Eval.hs
View File

@ -8,110 +8,87 @@ import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
evalSingle :: Map String T -> TricuAST -> Map String T
evalSingle env term = case term of
SFunc name [] body ->
let lineNoLambda = eliminateLambda body
result = evalAST env lineNoLambda
in Map.insert "__result" result (Map.insert name result env)
SLambda _ body ->
let result = evalAST env body
in Map.insert "__result" result env
SApp func arg ->
let result = apply (evalAST env $ eliminateLambda func) (evalAST env $ eliminateLambda arg)
in Map.insert "__result" result env
SVar name ->
case Map.lookup name env of
Just value -> Map.insert "__result" value env
evalSingle :: Env -> TricuAST -> Env
evalSingle env term
| SFunc name [] body <- term =
let res = evalAST env $ elimLambda body
in Map.insert "__result" res (Map.insert name res env)
| SLambda _ body <- term = Map.insert "__result" (evalAST env body) env
| SApp func arg <- term = Map.insert "__result"
(apply (evalAST env $ elimLambda func) (evalAST env $ elimLambda arg)) env
| SVar name <- term = case Map.lookup name env of
Just v -> Map.insert "__result" v env
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
_ ->
let result = evalAST env term
in Map.insert "__result" result env
| otherwise = Map.insert "__result" (evalAST env term) env
evalTricu :: Map String T -> [TricuAST] -> Map String T
evalTricu :: Env -> [TricuAST] -> Env
evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
where
evalTricu' :: Map String T -> [TricuAST] -> Map String T
evalTricu' env [] = env
evalTricu' env [lastLine] =
let lastLineNoLambda = eliminateLambda lastLine
updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv
evalTricu' env (line:rest) =
let lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda
in evalTricu updatedEnv rest
evalTricu' :: Env -> [TricuAST] -> Env
evalTricu' env [] = env
evalTricu' env [s] =
let updatedEnv = evalSingle env $ elimLambda s
in Map.insert "__result" (result updatedEnv) updatedEnv
evalTricu' env (x:xs) = evalTricu (evalSingle env $ elimLambda x) xs
evalAST :: Map String T -> TricuAST -> T
evalAST env term = case term of
SVar name -> case Map.lookup name env of
Just value -> value
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
TLeaf -> Leaf
TStem t -> Stem (evalAST env t)
TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
SStr str -> ofString str
SInt num -> ofNumber num
SList elems -> ofList (map (evalAST env) elems)
SEmpty -> Leaf
SFunc name args body ->
errorWithoutStackTrace $ "Unexpected function definition " ++ name
SLambda {} -> errorWithoutStackTrace "Internal error: SLambda found in evalAST after elimination."
eliminateLambda :: TricuAST -> TricuAST
eliminateLambda (SLambda (v:vs) body)
| null vs = lambdaToT v (eliminateLambda body)
| otherwise = eliminateLambda (SLambda [v] (SLambda vs body))
eliminateLambda (SApp f arg) = SApp (eliminateLambda f) (eliminateLambda arg)
eliminateLambda (TStem t) = TStem (eliminateLambda t)
eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r)
eliminateLambda (SList xs) = SList (map eliminateLambda xs)
eliminateLambda other = other
evalAST :: Env -> TricuAST -> T
evalAST env 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
-- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
-- Chapter 4: Lambda-Abstraction
lambdaToT :: String -> TricuAST -> TricuAST
lambdaToT x (SVar y)
| x == y = tI
lambdaToT x (SVar y)
| x /= y = SApp tK (SVar y)
lambdaToT x t
| not (isFree x t) = SApp tK t
lambdaToT x (SApp n u)
| not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
lambdaToT x (SApp n u) = SApp (SApp tS (lambdaToT x (eliminateLambda n))) (lambdaToT x (eliminateLambda u))
lambdaToT x body
| not (isFree x body) = SApp tK body
| otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
elimLambda :: TricuAST -> TricuAST
elimLambda = go
where
go (SLambda (v:vs) body)
| null vs = toSKI v (elimLambda body)
| otherwise = elimLambda (SLambda [v] (SLambda vs body))
go (SApp f g ) = SApp (elimLambda f) (elimLambda g)
go (TStem t ) = TStem (elimLambda t)
go (TFork l r ) = TFork (elimLambda l) (elimLambda r)
go (SList x ) = SList (map elimLambda x)
go x = x
freeVars :: TricuAST -> Set.Set String
freeVars (SVar v) = Set.singleton v
freeVars (SInt _) = Set.empty
freeVars (SStr _) = Set.empty
freeVars (SList xs) = foldMap freeVars xs
freeVars (SApp f arg) = freeVars f <> freeVars arg
freeVars TLeaf = Set.empty
freeVars (SFunc _ _ b) = freeVars b
freeVars (TStem t) = freeVars t
freeVars (TFork l r) = freeVars l <> freeVars r
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
toSKI x (SVar y)
| x == y = _I
| otherwise = SApp _K (SVar y)
toSKI x t@(SApp n u)
| not (isFree x t) = SApp _K (SApp (elimLambda n) (elimLambda u))
| otherwise = SApp (SApp _S (toSKI x (elimLambda n))) (toSKI x (elimLambda u))
toSKI x t
| not (isFree x t) = SApp _K t
| otherwise = SApp (SApp _S (toSKI x t)) TLeaf
isFree :: String -> TricuAST -> Bool
isFree x = Set.member x . freeVars
_S = parseSingle "t (t (t t t)) t"
_K = parseSingle "t t"
_I = parseSingle "t (t (t t)) t"
isFree x = Set.member x . freeVars
freeVars (SVar v ) = Set.singleton v
freeVars (SInt _ ) = Set.empty
freeVars (SStr _ ) = Set.empty
freeVars (SList s ) = foldMap freeVars s
freeVars (SApp f a ) = freeVars f <> freeVars a
freeVars (TLeaf ) = Set.empty
freeVars (SFunc _ _ b) = freeVars b
freeVars (TStem t ) = freeVars t
freeVars (TFork l r ) = freeVars l <> freeVars r
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
-- We need the SKI operators in an unevaluated TricuAST tree form so that we
-- can keep the evaluation functions straightforward
tI :: TricuAST
tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
tK :: TricuAST
tK = SApp TLeaf TLeaf
tS :: TricuAST
tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf
result :: Map String T -> T
result :: Env -> T
result r = case Map.lookup "__result" r of
Just a -> a
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"

42
src/Parser.hs
View File

@ -17,18 +17,20 @@ type AltParser = Parsec Void String
parseTricu :: String -> [TricuAST]
parseTricu input
| null tokens = []
| otherwise = map parseSingle tokens
| otherwise = map parseSingle tokens
where
tokens = case lexTricu input of
[] -> []
tokens -> lines input
tokens
| null (lexTricu input) = []
| otherwise = lines input
parseSingle :: String -> TricuAST
parseSingle input = case lexTricu input of
[] -> SEmpty
tokens -> case runParser parseExpression "" tokens of
Left err -> error $ handleParseError err
Right ast -> ast
parseSingle input
| null tokens = SEmpty
| Left err <- parsed = error $ handleParseError err
| Right ast <- parsed = ast
where
tokens = lexTricu input
parsed = runParser parseExpression "" tokens
parseExpression :: Parser TricuAST
parseExpression = choice
@ -115,10 +117,10 @@ parseTreeTerm = do
rest <- many parseTreeLeafOrParenthesized
pure $ foldl combine base rest
where
combine acc next = case acc of
TLeaf -> TStem next
TStem t -> TFork t next
TFork _ _ -> TFork acc next
combine acc next
| TLeaf <- acc = TStem next
| TStem t <- acc = TFork t next
| TFork _ _ <- acc = TFork acc next
parseTreeLeafOrParenthesized :: Parser TricuAST
parseTreeLeafOrParenthesized = choice
@ -181,9 +183,9 @@ parseSingleItem :: Parser TricuAST
parseSingleItem = do
token <- satisfy isListItem
case token of
LIdentifier name -> return (SVar name)
LKeywordT -> return TLeaf
_ -> fail "Unexpected token in list item"
_ | LIdentifier name <- token -> return (SVar name)
| LKeywordT <- token -> return TLeaf
| otherwise -> fail "Unexpected token in list item"
isListItem :: LToken -> Bool
isListItem (LIdentifier _) = True
@ -254,9 +256,11 @@ parseTernaryFork = do
pure $ TFork term1 term2
parseTernary :: String -> Either String TricuAST
parseTernary input = case runParser (parseTernaryTerm <* eof) "" input of
Left err -> Left (errorBundlePretty err)
Right ast -> Right ast
parseTernary input
| Left err <- result = Left (errorBundlePretty err)
| Right ast <- result = Right ast
where
result = runParser (parseTernaryTerm <* eof) "" input
-- Error Handling
handleParseError :: ParseErrorBundle [LToken] Void -> String

65
src/REPL.hs
View File

@ -20,37 +20,36 @@ repl env = runInputT defaultSettings (loop env)
loop :: Env -> InputT IO ()
loop env = do
minput <- getInputLine "tricu < "
case minput of
Nothing -> outputStrLn "Exiting tricu"
Just s -> case strip s of
"!exit" -> outputStrLn "Exiting tricu"
"!load" -> do
path <- getInputLine "File path to load < "
case path of
Nothing -> do
outputStrLn "No input received; stopping import."
loop env
Just path -> do
loadedEnv <- liftIO $ evaluateFileWithContext env (strip path)
loop $ Map.delete "__result" (Map.union loadedEnv env)
"" -> do
outputStrLn ""
loop env
input -> do
case (take 2 input) of
"--" -> loop env
_ -> do
newEnv <- liftIO $ (processInput env input `catch` errorHandler env)
loop newEnv
if
| Nothing <- minput -> outputStrLn "Exiting tricu"
| Just s <- minput, strip s == "!exit" -> outputStrLn "Exiting tricu"
| Just s <- minput, strip s == "" -> do
outputStrLn ""
loop env
| Just s <- minput, strip s == "!load" -> do
path <- getInputLine "File path to load < "
if
| Nothing <- path -> do
outputStrLn "No input received; stopping import."
loop env
| Just p <- path -> do
loadedEnv <- liftIO $ evaluateFileWithContext env (strip p) `catch` \e -> errorHandler env e
loop $ Map.delete "__result" (Map.union loadedEnv env)
| Just s <- minput -> do
if
| take 2 s == "--" -> loop env
| otherwise -> do
newEnv <- liftIO $ processInput env s `catch` errorHandler env
loop newEnv
processInput :: Env -> String -> IO Env
processInput env input = do
let asts = parseTricu input
let asts = parseTricu input
newEnv = evalTricu env asts
case Map.lookup "__result" newEnv of
Just r -> do
if
| Just r <- Map.lookup "__result" newEnv -> do
putStrLn $ "tricu > " ++ decodeResult r
Nothing -> return ()
| otherwise -> return ()
return newEnv
errorHandler :: Env -> SomeException -> IO (Env)
@ -62,10 +61,8 @@ repl env = runInputT defaultSettings (loop env)
strip = dropWhileEnd isSpace . dropWhile isSpace
decodeResult :: T -> String
decodeResult tc = case toNumber tc of
Right num -> show num
Left _ -> case toString tc of
Right str -> "\"" ++ str ++ "\""
Left _ -> case toList tc of
Right list -> "[" ++ intercalate ", " (map decodeResult list) ++ "]"
Left _ -> formatResult TreeCalculus tc
decodeResult tc
| Right num <- toNumber tc = show num
| Right str <- toString tc = "\"" ++ str ++ "\""
| Right list <- toList tc = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
| otherwise = formatResult TreeCalculus tc

15
src/Research.hs
View File

@ -28,7 +28,7 @@ data TricuAST
| SEmpty
deriving (Show, Eq, Ord)
-- Tokens from Lexer
-- Lexer Tokens
data LToken
= LKeywordT
| LIdentifier String
@ -61,19 +61,6 @@ apply (Fork (Fork a1 a2) a3) Leaf = a1
apply (Fork (Fork a1 a2) a3) (Stem u) = apply a2 u
apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v
-- SKI Combinators
_S :: T
_S = Fork (Stem (Fork Leaf Leaf)) Leaf
_K :: T
_K = Stem Leaf
-- Identity
-- We use the "point-free" style which drops a redundant node
-- Full I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
_I :: T
_I = Fork (Stem (Stem Leaf)) Leaf
-- Booleans
_false :: T
_false = Leaf

11
test/Spec.hs
View File

@ -31,7 +31,6 @@ tests = testGroup "Tricu Tests"
, lambdaEvalTests
, libraryTests
, fileEvaluationTests
, propertyTests
]
lexerTests :: TestTree
@ -414,13 +413,3 @@ fileEvaluationTests = testGroup "Evaluation tests"
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
decodeResult (result res) @?= "\"String test!\""
]
propertyTests :: TestTree
propertyTests = testGroup "Property Tests"
[ testProperty "Lexing and parsing round-trip" $ \input ->
case runParser tricuLexer "" input of
Left _ -> property True
Right tokens -> case runParser parseExpression "" tokens of
Left _ -> property True
Right ast -> parseSingle input === ast
]

2
tricu.cabal
View File

@ -18,6 +18,7 @@ executable tricu
src
default-extensions:
DeriveDataTypeable
MultiWayIf
OverloadedStrings
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
build-depends:
@ -43,6 +44,7 @@ test-suite tricu-tests
hs-source-dirs: test, src
default-extensions:
DeriveDataTypeable
MultiWayIf
OverloadedStrings
build-depends:
base