tricu/src/FileEval.hs

module FileEval where

import Eval
import Lexer
import Parser
import Research

import Data.List       (partition)
import Control.Monad   (foldM)
import System.IO

import qualified Data.Map as Map
import qualified Data.Set as Set

evaluateFileResult :: FilePath -> IO T
evaluateFileResult filePath = do
  contents <- readFile filePath
  let tokens = lexTricu contents
  case parseProgram tokens of
    Left err -> errorWithoutStackTrace (handleParseError err)
    Right ast -> do
      ast <- preprocessFile filePath
      let finalEnv = evalTricu Map.empty ast
      case Map.lookup "main" finalEnv of
        Just finalResult -> return finalResult
        Nothing -> errorWithoutStackTrace "No `main` function detected"

evaluateFile :: FilePath -> IO Env
evaluateFile filePath = do
  contents <- readFile filePath
  let tokens = lexTricu contents
  case parseProgram tokens of
    Left err -> errorWithoutStackTrace (handleParseError err)
    Right ast -> do
      ast <- preprocessFile filePath
      pure $ evalTricu Map.empty ast

evaluateFileWithContext :: Env -> FilePath -> IO Env
evaluateFileWithContext env filePath = do
  contents <- readFile filePath
  let tokens = lexTricu contents
  case parseProgram tokens of
    Left err -> errorWithoutStackTrace (handleParseError err)
    Right ast -> do
      ast <- preprocessFile filePath
      pure $ evalTricu env ast

preprocessFile :: FilePath -> IO [TricuAST]
preprocessFile = preprocessFile' Set.empty

preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST]
preprocessFile' inProgress filePath
  | filePath `Set.member` inProgress = 
      errorWithoutStackTrace $ "Encountered cyclic import: " ++ filePath
  | otherwise = do
      contents <- readFile filePath
      let tokens = lexTricu contents
      case parseProgram tokens of
        Left err -> errorWithoutStackTrace (handleParseError err)
        Right asts -> do
          let (imports, nonImports) = partition isImport asts
          let newInProgress = Set.insert filePath inProgress
          importedASTs <- concat <$> mapM (processImport newInProgress "") imports
          pure $ importedASTs ++ nonImports
  where
    isImport :: TricuAST -> Bool
    isImport (SImport _ _) = True
    isImport _             = False

    processImport :: Set.Set FilePath -> String -> TricuAST -> IO [TricuAST]
    processImport prog currentModule (SImport path "!Local") = do
      ast <- preprocessFile' prog path
      let defs = filter (not . isImport) ast
      pure $ map (nsDefinition currentModule) defs
    processImport prog _ (SImport path name) = do
      ast <- preprocessFile' prog path
      let defs = filter (not . isImport) ast
      pure $ map (nsDefinition name) defs
    processImport _ _ _ = error "Unexpected non-import in processImport"

nsDefinitions :: String -> [TricuAST] -> [TricuAST]
nsDefinitions moduleName = map (nsDefinition moduleName)

nsDefinition :: String -> TricuAST -> TricuAST
nsDefinition "" def = def
nsDefinition moduleName (SDef name args body)
  | isPrefixed name = SDef name args (nsBody moduleName body)
  | otherwise = SDef (nsVariable moduleName name) 
                        args (nsBody moduleName body)
nsDefinition moduleName other =
  nsBody moduleName other

nsBody :: String -> TricuAST -> TricuAST
nsBody moduleName (SVar name)
  | isPrefixed name = SVar name
  | otherwise = SVar (nsVariable moduleName name)
nsBody moduleName (SApp func arg) =
  SApp (nsBody moduleName func) (nsBody moduleName arg)
nsBody moduleName (SLambda args body) =
  SLambda args (nsBodyScoped moduleName args body)
nsBody moduleName (SList items) =
  SList (map (nsBody moduleName) items)
nsBody moduleName (TFork left right) =
  TFork (nsBody moduleName left) (nsBody moduleName right)
nsBody moduleName (TStem subtree) =
  TStem (nsBody moduleName subtree)
nsBody moduleName (SDef name args body)
  | isPrefixed name = SDef name args (nsBody moduleName body)
  | otherwise = SDef (nsVariable moduleName name) 
                        args (nsBody moduleName body)
nsBody _ other = other

nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
nsBodyScoped moduleName args body = case body of
  SVar name ->
    if name `elem` args
      then SVar name
      else nsBody moduleName (SVar name)
  SApp func arg -> SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
  SLambda innerArgs innerBody -> SLambda innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
  SList items -> SList (map (nsBodyScoped moduleName args) items)
  TFork left right -> TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right)
  TStem subtree -> TStem (nsBodyScoped moduleName args subtree)
  SDef name innerArgs innerBody ->
    SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
  other -> other

isPrefixed :: String -> Bool
isPrefixed name = '.' `elem` name

nsVariable :: String -> String -> String
nsVariable "" name = name
nsVariable moduleName name = moduleName ++ "." ++ name