113 lines
4.0 KiB
Haskell
113 lines
4.0 KiB
Haskell
module Eval where
|
|
|
|
import Parser
|
|
import Research
|
|
|
|
import Data.Map (Map)
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
|
|
evalSingle :: Env -> TricuAST -> Env
|
|
evalSingle env term
|
|
| SFunc name [] body <- term =
|
|
if
|
|
| Map.member name env ->
|
|
errorWithoutStackTrace $
|
|
"Error: Identifier '" ++ name ++ "' is already defined."
|
|
| otherwise ->
|
|
let res = evalAST env body
|
|
in Map.insert "__result" res (Map.insert name res env)
|
|
| SApp func arg <- term =
|
|
let res = apply (evalAST env func) (evalAST env arg)
|
|
in Map.insert "__result" res env
|
|
| SVar name <- term =
|
|
case Map.lookup name env of
|
|
Just v -> Map.insert "__result" v env
|
|
Nothing -> errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined"
|
|
| otherwise =
|
|
Map.insert "__result" (evalAST env term) env
|
|
|
|
evalTricu :: Env -> [TricuAST] -> Env
|
|
evalTricu env [] = env
|
|
evalTricu env [x] =
|
|
let updatedEnv = evalSingle env x
|
|
in Map.insert "__result" (result updatedEnv) updatedEnv
|
|
evalTricu env (x:xs) =
|
|
evalTricu (evalSingle env x) xs
|
|
|
|
evalAST :: Env -> TricuAST -> T
|
|
evalAST env term
|
|
| SLambda _ _ <- term = evalAST env (elimLambda 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
|
|
|
|
elimLambda :: TricuAST -> TricuAST
|
|
elimLambda = go
|
|
where
|
|
-- η-reduction
|
|
go (SLambda [v] (SApp f (SVar x)))
|
|
| v == x && not (isFree v f) = elimLambda f
|
|
-- Triage optimization
|
|
go (SLambda [a] (SLambda [b] (SLambda [c] body)))
|
|
| body == triageBody = _TRIAGE
|
|
where
|
|
triageBody =
|
|
(SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c))
|
|
-- Composition optimization
|
|
go (SLambda [f] (SLambda [g] (SLambda [x] body)))
|
|
| body == composeBody = _COMPOSE
|
|
where
|
|
composeBody = SApp (SVar f) (SApp (SVar g) (SVar x))
|
|
-- General elimination
|
|
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 x = x
|
|
|
|
toSKI x (SVar y)
|
|
| x == y = _I
|
|
| otherwise = SApp _K (SVar y)
|
|
toSKI x t@(SApp n u)
|
|
| not (isFree x t) = SApp _K t
|
|
| otherwise = SApp (SApp _S (toSKI x n)) (toSKI x u)
|
|
toSKI x t
|
|
| not (isFree x t) = SApp _K t
|
|
| otherwise = errorWithoutStackTrace "Unhandled toSKI conversion"
|
|
|
|
_S = parseSingle "t (t (t t t)) t"
|
|
_K = parseSingle "t t"
|
|
_I = parseSingle "t (t (t t)) t"
|
|
_TRIAGE = parseSingle "t (t (t t (t (t (t t t))))) t"
|
|
_COMPOSE = parseSingle "t (t (t t (t (t (t 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
|
|
|
|
result :: Env -> T
|
|
result r = case Map.lookup "__result" r of
|
|
Just a -> a
|
|
Nothing -> errorWithoutStackTrace "No __result field found in provided environment"
|