--! -h400K -P{HUGS}lib
-- (Line above is for Mac hugs.) 
--
-- file:    entre.lhs
--
-- created: 11/11/96 by Andrew Rock (maintaining the rage).
--
-- purpose: This is the main module of a program to implement a simple
--          functional programming interpreter based on term rewriting:
--          Explicit Naive Term Rewriting Engine. 
--          The explict bit is the important bit. The program will print out
--          what it's doing at every step, to help students understand how
--          the computation is performed.
--

> module Main (main) where

> import System
> import Parser
> import Lexer
> import Expr
> import Bindings
> import Eval
> import Cmd
> import Script


==================
The main functions
==================

This is the main function for stand-alone operation after compilation
with GHC.

> main :: IO ()
> main
>    = do putStr entreHeading
>         prelude <- readPrelude
>         if prelude == [] then putStrLn "Prelude empty or not found."
>                          else return ()
>         let (errs,b) = fprocess prelude newBind
>         putStr errs
>         putStr entreHelpful
>         process b

This is alternate entry point for use within HUGS. It doesn't read
the prelude or try to access environment variables. The former makes
it quicker and the latter makes it work.

> entre :: IO ()
> entre
>    = do putStr entreHeading
>         prelude <- readPrelude'
>         if prelude == [] then putStrLn "Prelude empty or not found."
>                          else return ()
>         let (errs,b) = fprocess prelude newBind
>         putStr errs
>         putStr entreHelpful
>         process b


======================
Handling user commands
======================

This asks for and handles user interactive commands.

> process :: Bindings -> IO ()
> process b
>    = do 
>         putStr entrePrompt
>         xs <- getLine
>         let c = readCommand xs 
>         case c of
>             Quit         -> putStr entreGoodbye
>             Expression e -> do eval b e
>                                process b
>             Laat e       -> do walk b e
>                                process b
>             Fewer e      -> do fewer b e
>                                process b
>             WF e         -> do walkFewer b e
>                                process b
>             Silent e     -> do silent b e
>                                process b
>             Bind n e     -> process (updateBind n e b)
>             Eval n e     -> process (updateBind n (evalExpr b e) b)
>             Help         -> do putStr helpStr
>                                process b
>             Print        -> do putStr (printBind b)
>                                process b
>             Blank        -> process b
>             Typo pos msg -> do putStrLn (errMsg pos msg xs)
>                                process b
>             Read f    -> do ys <- (catch (readFile f) (\e -> return []))
>                             if ys == []
>                                then do putStr "File empty or nonexistent.\n"
>                                        process b
>                                else do let (zs,b') = fprocess ys b 
>                                        putStr zs
>                                        process b'


=============================
Expression evaluation methods
=============================

> eval :: Bindings -> Expr -> IO ()
> eval b e = case lookupBind "print_mode" b of
>               Name "s"  -> silent b e
>               Name "f"  -> fewer b e
>               Name "w"  -> walk b e
>               Name "fw" -> walkFewer b e
>               Name "wf" -> walkFewer b e
>               _         -> (putStr . displayTrace) (traceExpr b e)

> silent :: Bindings -> Expr -> IO ()
> silent b e = (putStr . displayTrace) [evalExpr b e]

> fewer :: Bindings -> Expr -> IO ()
> fewer b e = (putStr . displayTrace) (traceExpr' b e)

> walk :: Bindings -> Expr -> IO ()
> walk b e = (lineAtATime . displayTrace) (traceExpr b e)

> walkFewer :: Bindings -> Expr -> IO ()
> walkFewer b e = (lineAtATime . displayTrace) (traceExpr' b e)


=====================
Line at a time output
=====================

> lineAtATime :: String -> IO ()
> lineAtATime
>    = laat . lines
>      where
>      laat :: [String] -> IO ()
>      laat []
>         = return ()
>      laat [s]
>         = putStrLn s
>      laat [s,s']
>         =  do putStrLn s
>               putStrLn s'
>      laat (s:ss)
>         = do putStrLn s
>              xs <- getLine
>              laat ss


================
Handling scripts
================

readPrelude returns the contents of the prelude script or [] if not found or
empty. The path to the prelude should be in the environment variable
ENTRE_PRELUDE. If not we assume the file is in the current working directory
and named prelude.es.

> readPrelude :: IO String
> readPrelude
>   = do pName <- (catch (getEnv "ENTRE_PRELUDE") (\e -> return "prelude.es"))
>        putStrLn ("Reading prelude: " ++ pName)
>        catch (readFile pName) (\e -> return [])


readPrelude' returns the contents of the prelude which must be in the current
working directory and named prelude.es. 

> readPrelude' :: IO String
> readPrelude'
>   = do let pName = "prelude.es"
>        putStrLn ("Reading prelude: " ++ pName)
>        catch (readFile pName) (\e -> return [])


This updates Bindings b with those in the source.
This returns any error messages and the updated bindings.

> fprocess :: String -> Bindings -> (String, Bindings)
> fprocess source b
>    = case lexerL (preLex source) of
>         Error pos msg -> (errMsg pos msg source, b)
>         OK (ls,_)     -> case scriptP (offside ls) of
>                             Error pos' msg' -> (errMsg pos' msg' source, b)
>                             OK (ds,_)       -> ("", foldr loadDef b ds)

> loadDef :: Def -> Bindings -> Bindings
> loadDef (Binds name expr) b = updateBind name expr b
> loadDef (Evals name expr) b = updateBind name (evalExpr b expr) b
> loadDef Blanks            b = b