tricu/src/Eval.hs

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 =
      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"
  | otherwise                  = Map.insert "__result" (evalAST env term) env

evalTricu :: Env -> [TricuAST] -> Env
evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
  where
    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 :: 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
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

    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 (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"