module Main
(
    main
)
where

import Isomorphism
import MonadF   -- Figure  1: Haskell code for supporting pseudomonads
import Package  -- Figure  3: Support code for packages
import Base     -- Figure  4: The base interpreter prepackage
import Complete -- Figure  5: Code to complete a constructed interpreter, part I
import Numbers  -- Figure  8: The numbers building block
import Nondet   -- Figure 10: The nondeterministic building block
import CBV      -- Figure 12: The call-by-value building block
import CBN      -- Figure 14: The call-by-name building block
import Cont     -- Figure 15: The continuation building block
import Errors   -- Figure 17: The errors building block

import qualified System.Console.Readline as Readline

-- Figure 5: Code to complete a constructed interpreter
-- (Part II, continuing module Complete)

-- Steele's code in Figure 5 contains the two type definitions
--
--      type Term  = ... TermZ
--      type Value = ... ValueZ
--
-- In no other place does his code actually refer to Term or Value.
-- Presumably, these definitions are only necessary to allow Steele's
-- program simplifier to output working Haskell code.  In our formulation,
-- there is no need to define the type synonyms Term and Value; indeed,
-- defining them would force the individual building block modules to
-- export more symbols than otherwise necessary.

interp_pkg = complete (continuation (nondeterministic
             (errors (cbv (numbers interpreter)))))

parse = parser interp_pkg
interp = interpr interp_pkg
showval = showvalr interp_pkg
complain = complainr interp_pkg
makenum = makenumr interp_pkg
makefun = makefunr interp_pkg
apply = applyr interp_pkg
name = namer interp_pkg

-- Figure 6: Code to drive a constructed interpreter

read_eval_print s = showval (interp exp []) where
    ((exp, _) : _) = parse s

-- A straightforward translation into Steele's interpreter driver code
-- into Haskell 98's monadic IO style results in the commented-out code
-- below.

{-
main = do putStr ("Welcome to the " ++ name ++ "!\n> ")
          contents <- getContents
          process (lines contents)
    where process [] = return ()
          process (x:xs) = do putStr (read_eval_print x)
                              putStr "\n> "
                              process xs
-}

-- Unfortunately, the code above does not work under Hugs 98 February 2001,
-- for what appears to be buffering problems.  The following code works, at
-- the cost of diverging further from Steele's original.

{-
main = do putStrLn ("Welcome to the " ++ name ++ "!")
          sequence_ (repeat (do putStr "> "
                                line <- getLine
                                putStrLn (read_eval_print line)))
-}

-- But wait, we can do better! Let's use GNU readline!

main = do putStrLn ("Welcome to the " ++ name ++ "!")
          main'
    where main' = do maybeLine <- Readline.readline "> "
                     case maybeLine of
                         Nothing   -> putStrLn "Bye!"
                         Just line -> do Readline.addHistory line
                                         putStrLn (read_eval_print line)
                                         main'