General refactor for legibility
Priming to update all source to lhs and document extensively
This commit is contained in:
James Eversole
parent
63aa977efd
commit
e6e05b607a
163
src/Eval.hs
163
src/Eval.hs
@ -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"
|
||||
|
||||
@ -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
65
src/REPL.hs
@ -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
|
||||
|
||||
@ -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
11
test/Spec.hs
@ -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
|
||||
]
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user