tricu/src/Eval.hs

module Eval where

import Parser
import Research

import qualified Data.Map as Map
import           Data.Map   (Map)

evalSingle :: Map String T -> SaplingAST -> Map String T
evalSingle env TLeaf = Map.insert "__result" Leaf env
evalSingle env (TStem t) =
    let result = Stem (evalTreeCalculus env t)
    in Map.insert "__result" result env
evalSingle env (TFork t1 t2) =
    let result = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2)
    in Map.insert "__result" result env
evalSingle env (SFunc name [] body) =
    let value = evalTreeCalculus env body
    in Map.insert name value env
evalSingle env (SVar name) =
    case Map.lookup name env of
      Just value -> Map.insert "__result" value env
      Nothing -> error $ "Variable " ++ name ++ " not defined"
evalSingle env ast = Map.insert "__result" (evalTreeCalculus env ast) env

evalSapling :: Map String T -> [SaplingAST] -> Map String T
evalSapling env [] = env
evalSapling env [lastLine] =
    let updatedEnv = evalSingle env lastLine
    in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) =
    let updatedEnv = evalSingle env line
    in evalSapling updatedEnv rest

evalTreeCalculus :: Map.Map String T -> SaplingAST -> T
evalTreeCalculus _ TLeaf = Leaf
evalTreeCalculus env (TStem t) = Stem (evalTreeCalculus env t)
evalTreeCalculus env (TFork t1 t2) = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2)
evalTreeCalculus env (SApp base []) = evalTreeCalculus env base
evalTreeCalculus env (SApp base args) =
    let func = evalTreeCalculus env base
        argVals = map (evalTreeCalculus env) args
    in foldl apply func argVals
evalTreeCalculus env (SVar name) =
    case Map.lookup name env of
      Just value -> value 
      Nothing -> error $ "Variable " ++ name ++ " not defined"
evalTreeCalculus _ (SStr str) = toString str
evalTreeCalculus _ (SInt num) = toNumber num
evalTreeCalculus _ (SList elems) = toList (map (evalTreeCalculus Map.empty) elems)
evalTreeCalculus _ (SFunc name args body) =
    error $ "Unexpected function definition " ++ name ++ " in \ 
           \ evalTreeCalculus; functions should be evaluated to Tree Calculus \
           \ terms by evalSingle."

result :: Map String T -> T
result r = case (Map.lookup "__result" r) of
  Just a  -> a
  Nothing -> error "No __result field found in provided environment"

toAST :: T -> SaplingAST
toAST Leaf       = TLeaf
toAST (Stem a)   = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b)