General refactor for legibility
Priming to update all source to lhs and document extensively
This commit is contained in:
James Eversole
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"
|
||||
|
||||
Reference in New Issue
Block a user