General refactor for legibility
Priming to update all source to lhs and document extensively
This commit is contained in:
parent
a3282b794f
commit
ad02c8b86a
149
src/Eval.hs
149
src/Eval.hs
@ -8,110 +8,87 @@ import Data.Map (Map)
|
|||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
evalSingle :: Map String T -> TricuAST -> Map String T
|
evalSingle :: Env -> TricuAST -> Env
|
||||||
evalSingle env term = case term of
|
evalSingle env term
|
||||||
SFunc name [] body ->
|
| SFunc name [] body <- term =
|
||||||
let lineNoLambda = eliminateLambda body
|
let res = evalAST env $ elimLambda body
|
||||||
result = evalAST env lineNoLambda
|
in Map.insert "__result" res (Map.insert name res env)
|
||||||
in Map.insert "__result" result (Map.insert name result env)
|
| SLambda _ body <- term = Map.insert "__result" (evalAST env body) env
|
||||||
SLambda _ body ->
|
| SApp func arg <- term = Map.insert "__result"
|
||||||
let result = evalAST env body
|
(apply (evalAST env $ elimLambda func) (evalAST env $ elimLambda arg)) env
|
||||||
in Map.insert "__result" result env
|
| SVar name <- term = case Map.lookup name env of
|
||||||
SApp func arg ->
|
Just v -> Map.insert "__result" v env
|
||||||
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
|
|
||||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
||||||
_ ->
|
| otherwise = Map.insert "__result" (evalAST env term) env
|
||||||
let result = evalAST env term
|
|
||||||
in Map.insert "__result" result env
|
|
||||||
|
|
||||||
evalTricu :: Map String T -> [TricuAST] -> Map String T
|
evalTricu :: Env -> [TricuAST] -> Env
|
||||||
evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
|
evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
|
||||||
where
|
where
|
||||||
evalTricu' :: Map String T -> [TricuAST] -> Map String T
|
evalTricu' :: Env -> [TricuAST] -> Env
|
||||||
evalTricu' env [] = env
|
evalTricu' env [] = env
|
||||||
evalTricu' env [lastLine] =
|
evalTricu' env [s] =
|
||||||
let lastLineNoLambda = eliminateLambda lastLine
|
let updatedEnv = evalSingle env $ elimLambda s
|
||||||
updatedEnv = evalSingle env lastLineNoLambda
|
|
||||||
in Map.insert "__result" (result updatedEnv) updatedEnv
|
in Map.insert "__result" (result updatedEnv) updatedEnv
|
||||||
evalTricu' env (line:rest) =
|
evalTricu' env (x:xs) = evalTricu (evalSingle env $ elimLambda x) xs
|
||||||
let lineNoLambda = eliminateLambda line
|
|
||||||
updatedEnv = evalSingle env lineNoLambda
|
|
||||||
in evalTricu updatedEnv rest
|
|
||||||
|
|
||||||
evalAST :: Map String T -> TricuAST -> T
|
evalAST :: Env -> TricuAST -> T
|
||||||
evalAST env term = case term of
|
evalAST env term
|
||||||
SVar name -> case Map.lookup name env of
|
| SVar name <- term = evalVar name
|
||||||
Just value -> value
|
| TLeaf <- term = Leaf
|
||||||
Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
|
| TStem t <- term = Stem (evalAST env t)
|
||||||
TLeaf -> Leaf
|
| TFork t u <- term = Fork (evalAST env t) (evalAST env u)
|
||||||
TStem t -> Stem (evalAST env t)
|
| SApp t u <- term = apply (evalAST env t) (evalAST env u)
|
||||||
TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
|
| SStr s <- term = ofString s
|
||||||
SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
|
| SInt n <- term = ofNumber n
|
||||||
SStr str -> ofString str
|
| SList xs <- term = ofList (map (evalAST env) xs)
|
||||||
SInt num -> ofNumber num
|
| SEmpty <- term = Leaf
|
||||||
SList elems -> ofList (map (evalAST env) elems)
|
| otherwise = errorWithoutStackTrace "Unexpected AST term"
|
||||||
SEmpty -> Leaf
|
where
|
||||||
SFunc name args body ->
|
evalVar name = Map.findWithDefault
|
||||||
errorWithoutStackTrace $ "Unexpected function definition " ++ name
|
(errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
|
||||||
SLambda {} -> errorWithoutStackTrace "Internal error: SLambda found in evalAST after elimination."
|
name env
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
-- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
|
-- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
|
||||||
-- Chapter 4: Lambda-Abstraction
|
-- Chapter 4: Lambda-Abstraction
|
||||||
lambdaToT :: String -> TricuAST -> TricuAST
|
elimLambda :: TricuAST -> TricuAST
|
||||||
lambdaToT x (SVar y)
|
elimLambda = go
|
||||||
| x == y = tI
|
where
|
||||||
lambdaToT x (SVar y)
|
go (SLambda (v:vs) body)
|
||||||
| x /= y = SApp tK (SVar y)
|
| null vs = toSKI v (elimLambda body)
|
||||||
lambdaToT x t
|
| otherwise = elimLambda (SLambda [v] (SLambda vs body))
|
||||||
| not (isFree x t) = SApp tK t
|
go (SApp f g ) = SApp (elimLambda f) (elimLambda g)
|
||||||
lambdaToT x (SApp n u)
|
go (TStem t ) = TStem (elimLambda t)
|
||||||
| not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
|
go (TFork l r ) = TFork (elimLambda l) (elimLambda r)
|
||||||
lambdaToT x (SApp n u) = SApp (SApp tS (lambdaToT x (eliminateLambda n))) (lambdaToT x (eliminateLambda u))
|
go (SList x ) = SList (map elimLambda x)
|
||||||
lambdaToT x body
|
go x = x
|
||||||
| not (isFree x body) = SApp tK body
|
|
||||||
| otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
|
|
||||||
|
|
||||||
freeVars :: TricuAST -> Set.Set String
|
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
|
||||||
|
|
||||||
|
_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 (SVar v ) = Set.singleton v
|
||||||
freeVars (SInt _ ) = Set.empty
|
freeVars (SInt _ ) = Set.empty
|
||||||
freeVars (SStr _ ) = Set.empty
|
freeVars (SStr _ ) = Set.empty
|
||||||
freeVars (SList xs) = foldMap freeVars xs
|
freeVars (SList s ) = foldMap freeVars s
|
||||||
freeVars (SApp f arg) = freeVars f <> freeVars arg
|
freeVars (SApp f a ) = freeVars f <> freeVars a
|
||||||
freeVars TLeaf = Set.empty
|
freeVars (TLeaf ) = Set.empty
|
||||||
freeVars (SFunc _ _ b) = freeVars b
|
freeVars (SFunc _ _ b) = freeVars b
|
||||||
freeVars (TStem t ) = freeVars t
|
freeVars (TStem t ) = freeVars t
|
||||||
freeVars (TFork l r ) = freeVars l <> freeVars r
|
freeVars (TFork l r ) = freeVars l <> freeVars r
|
||||||
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
|
freeVars (SLambda v b ) = foldr Set.delete (freeVars b) v
|
||||||
|
|
||||||
isFree :: String -> TricuAST -> Bool
|
result :: Env -> T
|
||||||
isFree x = Set.member x . freeVars
|
|
||||||
|
|
||||||
-- 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 r = case Map.lookup "__result" r of
|
result r = case Map.lookup "__result" r of
|
||||||
Just a -> a
|
Just a -> a
|
||||||
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"
|
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"
|
||||||
|
@ -19,16 +19,18 @@ parseTricu input
|
|||||||
| null tokens = []
|
| null tokens = []
|
||||||
| otherwise = map parseSingle tokens
|
| otherwise = map parseSingle tokens
|
||||||
where
|
where
|
||||||
tokens = case lexTricu input of
|
tokens
|
||||||
[] -> []
|
| null (lexTricu input) = []
|
||||||
tokens -> lines input
|
| otherwise = lines input
|
||||||
|
|
||||||
parseSingle :: String -> TricuAST
|
parseSingle :: String -> TricuAST
|
||||||
parseSingle input = case lexTricu input of
|
parseSingle input
|
||||||
[] -> SEmpty
|
| null tokens = SEmpty
|
||||||
tokens -> case runParser parseExpression "" tokens of
|
| Left err <- parsed = error $ handleParseError err
|
||||||
Left err -> error $ handleParseError err
|
| Right ast <- parsed = ast
|
||||||
Right ast -> ast
|
where
|
||||||
|
tokens = lexTricu input
|
||||||
|
parsed = runParser parseExpression "" tokens
|
||||||
|
|
||||||
parseExpression :: Parser TricuAST
|
parseExpression :: Parser TricuAST
|
||||||
parseExpression = choice
|
parseExpression = choice
|
||||||
@ -115,10 +117,10 @@ parseTreeTerm = do
|
|||||||
rest <- many parseTreeLeafOrParenthesized
|
rest <- many parseTreeLeafOrParenthesized
|
||||||
pure $ foldl combine base rest
|
pure $ foldl combine base rest
|
||||||
where
|
where
|
||||||
combine acc next = case acc of
|
combine acc next
|
||||||
TLeaf -> TStem next
|
| TLeaf <- acc = TStem next
|
||||||
TStem t -> TFork t next
|
| TStem t <- acc = TFork t next
|
||||||
TFork _ _ -> TFork acc next
|
| TFork _ _ <- acc = TFork acc next
|
||||||
|
|
||||||
parseTreeLeafOrParenthesized :: Parser TricuAST
|
parseTreeLeafOrParenthesized :: Parser TricuAST
|
||||||
parseTreeLeafOrParenthesized = choice
|
parseTreeLeafOrParenthesized = choice
|
||||||
@ -181,9 +183,9 @@ parseSingleItem :: Parser TricuAST
|
|||||||
parseSingleItem = do
|
parseSingleItem = do
|
||||||
token <- satisfy isListItem
|
token <- satisfy isListItem
|
||||||
case token of
|
case token of
|
||||||
LIdentifier name -> return (SVar name)
|
_ | LIdentifier name <- token -> return (SVar name)
|
||||||
LKeywordT -> return TLeaf
|
| LKeywordT <- token -> return TLeaf
|
||||||
_ -> fail "Unexpected token in list item"
|
| otherwise -> fail "Unexpected token in list item"
|
||||||
|
|
||||||
isListItem :: LToken -> Bool
|
isListItem :: LToken -> Bool
|
||||||
isListItem (LIdentifier _) = True
|
isListItem (LIdentifier _) = True
|
||||||
@ -254,9 +256,11 @@ parseTernaryFork = do
|
|||||||
pure $ TFork term1 term2
|
pure $ TFork term1 term2
|
||||||
|
|
||||||
parseTernary :: String -> Either String TricuAST
|
parseTernary :: String -> Either String TricuAST
|
||||||
parseTernary input = case runParser (parseTernaryTerm <* eof) "" input of
|
parseTernary input
|
||||||
Left err -> Left (errorBundlePretty err)
|
| Left err <- result = Left (errorBundlePretty err)
|
||||||
Right ast -> Right ast
|
| Right ast <- result = Right ast
|
||||||
|
where
|
||||||
|
result = runParser (parseTernaryTerm <* eof) "" input
|
||||||
|
|
||||||
-- Error Handling
|
-- Error Handling
|
||||||
handleParseError :: ParseErrorBundle [LToken] Void -> String
|
handleParseError :: ParseErrorBundle [LToken] Void -> String
|
||||||
|
55
src/REPL.hs
55
src/REPL.hs
@ -20,37 +20,36 @@ repl env = runInputT defaultSettings (loop env)
|
|||||||
loop :: Env -> InputT IO ()
|
loop :: Env -> InputT IO ()
|
||||||
loop env = do
|
loop env = do
|
||||||
minput <- getInputLine "tricu < "
|
minput <- getInputLine "tricu < "
|
||||||
case minput of
|
if
|
||||||
Nothing -> outputStrLn "Exiting tricu"
|
| Nothing <- minput -> outputStrLn "Exiting tricu"
|
||||||
Just s -> case strip s of
|
| Just s <- minput, strip s == "!exit" -> outputStrLn "Exiting tricu"
|
||||||
"!exit" -> outputStrLn "Exiting tricu"
|
| Just s <- minput, strip s == "" -> do
|
||||||
"!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 ""
|
outputStrLn ""
|
||||||
loop env
|
loop env
|
||||||
input -> do
|
| Just s <- minput, strip s == "!load" -> do
|
||||||
case (take 2 input) of
|
path <- getInputLine "File path to load < "
|
||||||
"--" -> loop env
|
if
|
||||||
_ -> do
|
| Nothing <- path -> do
|
||||||
newEnv <- liftIO $ (processInput env input `catch` errorHandler env)
|
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
|
loop newEnv
|
||||||
|
|
||||||
processInput :: Env -> String -> IO Env
|
processInput :: Env -> String -> IO Env
|
||||||
processInput env input = do
|
processInput env input = do
|
||||||
let asts = parseTricu input
|
let asts = parseTricu input
|
||||||
newEnv = evalTricu env asts
|
newEnv = evalTricu env asts
|
||||||
case Map.lookup "__result" newEnv of
|
if
|
||||||
Just r -> do
|
| Just r <- Map.lookup "__result" newEnv -> do
|
||||||
putStrLn $ "tricu > " ++ decodeResult r
|
putStrLn $ "tricu > " ++ decodeResult r
|
||||||
Nothing -> return ()
|
| otherwise -> return ()
|
||||||
return newEnv
|
return newEnv
|
||||||
|
|
||||||
errorHandler :: Env -> SomeException -> IO (Env)
|
errorHandler :: Env -> SomeException -> IO (Env)
|
||||||
@ -62,10 +61,8 @@ repl env = runInputT defaultSettings (loop env)
|
|||||||
strip = dropWhileEnd isSpace . dropWhile isSpace
|
strip = dropWhileEnd isSpace . dropWhile isSpace
|
||||||
|
|
||||||
decodeResult :: T -> String
|
decodeResult :: T -> String
|
||||||
decodeResult tc = case toNumber tc of
|
decodeResult tc
|
||||||
Right num -> show num
|
| Right num <- toNumber tc = show num
|
||||||
Left _ -> case toString tc of
|
| Right str <- toString tc = "\"" ++ str ++ "\""
|
||||||
Right str -> "\"" ++ str ++ "\""
|
| Right list <- toList tc = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
|
||||||
Left _ -> case toList tc of
|
| otherwise = formatResult TreeCalculus tc
|
||||||
Right list -> "[" ++ intercalate ", " (map decodeResult list) ++ "]"
|
|
||||||
Left _ -> formatResult TreeCalculus tc
|
|
||||||
|
@ -28,7 +28,7 @@ data TricuAST
|
|||||||
| SEmpty
|
| SEmpty
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
-- Tokens from Lexer
|
-- Lexer Tokens
|
||||||
data LToken
|
data LToken
|
||||||
= LKeywordT
|
= LKeywordT
|
||||||
| LIdentifier String
|
| 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) (Stem u) = apply a2 u
|
||||||
apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v
|
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
|
-- Booleans
|
||||||
_false :: T
|
_false :: T
|
||||||
_false = Leaf
|
_false = Leaf
|
||||||
|
11
test/Spec.hs
11
test/Spec.hs
@ -31,7 +31,6 @@ tests = testGroup "Tricu Tests"
|
|||||||
, lambdaEvalTests
|
, lambdaEvalTests
|
||||||
, libraryTests
|
, libraryTests
|
||||||
, fileEvaluationTests
|
, fileEvaluationTests
|
||||||
, propertyTests
|
|
||||||
]
|
]
|
||||||
|
|
||||||
lexerTests :: TestTree
|
lexerTests :: TestTree
|
||||||
@ -414,13 +413,3 @@ fileEvaluationTests = testGroup "Evaluation tests"
|
|||||||
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
|
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
|
||||||
decodeResult (result res) @?= "\"String test!\""
|
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
|
src
|
||||||
default-extensions:
|
default-extensions:
|
||||||
DeriveDataTypeable
|
DeriveDataTypeable
|
||||||
|
MultiWayIf
|
||||||
OverloadedStrings
|
OverloadedStrings
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
|
||||||
build-depends:
|
build-depends:
|
||||||
@ -43,6 +44,7 @@ test-suite tricu-tests
|
|||||||
hs-source-dirs: test, src
|
hs-source-dirs: test, src
|
||||||
default-extensions:
|
default-extensions:
|
||||||
DeriveDataTypeable
|
DeriveDataTypeable
|
||||||
|
MultiWayIf
|
||||||
OverloadedStrings
|
OverloadedStrings
|
||||||
build-depends:
|
build-depends:
|
||||||
base
|
base
|
||||||
|
Loading…
x
Reference in New Issue
Block a user