Main.hs

module Main where

import           Language.Cap.Interpret.Program
import           Language.Cap.Interpret.Parse
import qualified Language.Cap.Interpret.Pretty  as Pretty
import           Language.Cap.Debug.TraceMode
import           Language.Cap.Debug.Trace
import qualified Language.Cap.Debug.Algorithmic as Algorithmic
import           Language.Cap.Debug.EDT
import           Language.Cap.Debug.FDT
import qualified Language.Cap.Debug.Dotty       as Dotty

import System
import System.IO
import qualified Data.Map as M
import Data.List

-- | Interpreter and debugger for the TART language and trace.
main = do args <- System.getArgs
          let opts = options args
          hSetBuffering stdout NoBuffering
          hSetBuffering stdin LineBuffering
          if fileType opts == Trace
            then do catFile <- readFile $ fileName opts
                    trace (mode opts) (read catFile)
            else do capFile <- readFile $ fileName opts
                    interpretLoop (moduleName (fileName opts))
                                  (parseProgram capFile)
                                  []

-- | Event loop for the interactive interpretter
interpretLoop :: String -> Program -> [Graph] -> IO ()
interpretLoop name p xs =
  do putStr (name ++ " > ")
     x <- getLine
     runCommand name p xs x

-- | Understands a command from the user and does the appropriate thing.
runCommand :: String -> Program -> [Graph] -> String -> IO ()
runCommand name p xs ":q" = return ()
runCommand name p xs ":w" = do writeFile (name ++ ".pmt") (show xs)
                               interpretLoop name p xs
runCommand name p xs ":p" = do writeDots 1 name xs
                               interpretLoop name p xs
runCommand name p xs ":prog" = do putStrLn $ showProg p
                                  interpretLoop name p xs
runCommand name p xs ":s"  = do trace Stat xs
                                interpretLoop name p xs
runCommand name p xs (':':c) =
  case c of
    "ad"            -> do trace (AlgorithmicDebug (FDT Index)) xs
                          interpretLoop name p xs
    ('a':'d':' ':x) ->
      case x of
        "edt"           -> do trace (AlgorithmicDebug EDT) xs
                              interpretLoop name p xs
        ('f':'d':'t':y) -> 
          case y of
            " -o"  -> do trace (AlgorithmicDebug (FDT OnTheFly)) xs
                         interpretLoop name p xs
            " -i"  -> do trace (AlgorithmicDebug (FDT Index)) xs
                         interpretLoop name p xs
            " -if" -> do trace (AlgorithmicDebug (FDT IndexFunctions)) xs
                         interpretLoop name p xs
        _               -> do trace (AlgorithmicDebug (FDT Index)) xs
                              interpretLoop name p xs
    _               -> do putStrLn "Unknown command"
                          interpretLoop name p xs
runCommand name p xs l = do let g = interpret p (parseTerm l)
                            putStrLn $ Pretty.pretty $ nodeResult g ""
                            interpretLoop name p (g:xs)

writeDots :: Int -> String -> [Graph] -> IO ()
writeDots _ _ [] = return ()
writeDots n name (x:xs) =
  do writeFile (name ++ (show n) ++ ".dot") (Dotty.pretty x)
     writeDots (n + 1) name xs

{- | Trace a given graph in a specific node.  This generates a String -> String
     function that can be used by interact to create an interactive session.
-}
trace :: TraceMode -> [Graph] -> IO ()
trace Stat g = putStrLn $ concatMap stats g
trace (AlgorithmicDebug m) g =
  do putStrLn (concat (zipWith (\x y -> x ++ ".\t" ++ y ++ "\n")
                               (map show [1..])
                               (map ((flip dispReduction) "") g)))
     x <- getLine
     let reductionNum = (read x) :: Int
     let numReductions = length g
     if reductionNum > 0 && reductionNum <= numReductions
       then case m of 
              EDT ->
                Algorithmic.debug (g !! (reductionNum - 1)) buildEDT edtQuestion
              (FDT m) ->
                Algorithmic.debug (g !! (reductionNum - 1))
                                  buildFDT
                                  (fdtQuestion m)
       else putStrLn "Error: Reduction does not exist"

-- | Formats the program given to it.  Rules are grouped together according to
--   function symbol, and output with blank lines seperating functions
showProg :: Program -> String
showProg = concat . intersperse "\n" . map (concatMap showRule) . groupRules

-- | Takes a program and groups the rules by function symbol.
groupRules :: Program -> [Program]
groupRules [] = []
groupRules (r:rs) =
  groupRules' (r:rs) (functionName r) []
  where
    groupRules' :: Program -> String -> Program -> [Program]
    groupRules' [] _ _ = []
    groupRules' (r:rs) n g =
      if functionName r == n then groupRules' rs n (g ++ [r])
                             else (g:(groupRules' (r:rs) (functionName r) []))


-- | Generate statistics for a specific program run
stats :: Graph -> String
stats g =
     "Computation: " ++ dispReduction g ""
  ++ " |  Number of nodes: " ++ show (numNodes g) ++ "\n"
  ++ " |  Number of applications: " ++ show (numApps g) ++ "\n"
  ++ " |  Number of reductions: " ++ show (numReductions g) ++ "\n"
  ++ "------------\n"

{- | Strips the extension from the file name.
-}
moduleName :: String -> String
moduleName n
  | ".cap" `isSuffixOf` n = take (length n - 4) n
  | ".cat" `isSuffixOf` n = take (length n - 4) n
  | otherwise             = n