ctpl-0.1.0.4: debugger.hs

import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.STRef
import Data.Array.Unboxed
import Data.Array.ST
import Data.Char
import Data.Chatty.AVL
import Data.List
import System.Environment
import qualified Text.CTPL0 as Old
import qualified Text.CTPL0n as New

debugOld :: String -> String -> IO ()
debugOld prog str =
  let state0 = Old.CTPL0State buffer0 program0 register0 info0
      buffer0
        | null str = Old.BufferState [] (chr 3) []
        | otherwise = Old.BufferState [] (head str) (tail str ++ [chr 3])
      program0
        | null prog = Old.BufferState [] (chr 3) []
        | otherwise = Old.BufferState [] (head prog) (tail prog ++ [chr 3])
      register0 = Old.RegisterState 0 [] [length prog] [0] False
      info0 = Old.InfoState EmptyAVL
      imprf avl = sortBy (\b a -> snd a `compare` snd b) $ avlInorder avl
  in debugOldProg 10000 state0

debugOldProg :: Int -> Old.CTPL0State -> IO ()
debugOldProg limit state =
  let prst (Old.CTPL0State b p r f) i m =
        putStrLn (show (Old.unetx (reverse (Old.leftBehind b) ++ [Old.thisChar b] ++ Old.rightPending b)) ++ " I="++show i++" AX="++show (Old.ax r)++" CK="++concat(intersperse ":" (map show $ Old.ck r))++" IP=" ++ show (length $ Old.leftBehind p)++ " BP="++ show (length $ Old.leftBehind b) ++ " | "++m)
  in case Old.runCTPL0 Old.endOfInstr limit state of
    Old.Succ (True, st, i) -> prst st i "Program finished."
    Old.Succ (False, st, i) ->
      case Old.runCTPL0 Old.singleInstr limit state of
        Old.Succ (_, st, i) -> do
          prst st i "<>"
          debugOldProg i st
        Old.Expired -> putStrLn "Expired."
        Old.SynViol -> putStrLn "Syntax violation."
        Old.ConfViol -> putStrLn "Confidence violation."
  
debugNew :: String -> String -> IO ()
debugNew prog str = mapM_ putStrLn $ runST $ do
  let limit = New.maxTime New.safeVM
      bufsize = max (New.initBufferMeasure New.safeVM) (length str+1)
  bc <- newListArray (0, bufsize-1)  (str++'\3':replicate (bufsize-length str-1) '\0')
  let pc = listArray (0, length prog - 1) prog
      state0 = New.CTPL0State (New.MBuffer bc) pc 0 0 False 0 [] [length prog] [0]
  ref <- newSTRef state0
  debugNewProg limit ref New.safeVM

debugNewProg :: Int -> STRef s (New.CTPL0State s) -> New.VMConfig -> ST s [String]
debugNewProg limit state cfg =
  let prst ref i m = do
        New.CTPL0State bc pc bp pp cp ax mk rk ck <- readSTRef ref
        buf <- New.joinBuffer bc
        return (show buf ++ " I=" ++ show i ++ " AX=" ++ show ax ++ " CK="++concat(intersperse ":" $ map show ck) ++ " IP=" ++ show pp ++ " BP="++show bp++" | "++m)
  in do
    r <- New.runCTPL0 New.endOfInstr limit state cfg
    case r of
      New.Succ (True, i) -> return <$> prst state i "Program finished."
      New.Succ (False, i) -> do
        r <- New.runCTPL0 New.singleInstr limit state cfg
        case r of
          New.Succ (_, i) -> (:) <$> prst state i "<>" <*> debugNewProg i state cfg
          New.Fail f -> return [show f]

main = do
  args <- getArgs
  case args of
    ["--old", progf, buff] -> do
      prog <- readFile progf
      buf <- readFile buff
      debugOld (init prog) (init buf)
    ["--new", progf, buff] -> do
      prog <- readFile progf
      buf <- readFile buff
      debugNew (init prog) (init buf)
    ["--help"] -> do
      putStrLn "ctpl0debug 0.1"
      putStrLn "----------------"
      putStrLn "A debugger for CTPL0 (both VMs)"
      putStrLn "Synapsis:"
      putStrLn "  ctpl0debug --old <program-file> <input-file>"
      putStrLn "      Debugs execution with the old VM"
      putStrLn "  ctpl0debug --new <program-file> <input-file>"
      putStrLn "      Debugs execution with the new VM"
    _ -> putStrLn "Don't know what to do. See --help for help"