module Main where -- HatExplore main program import HatTrace import SExp (SExp(..),hatRep2SExp,sExp2Doc,arity,child,label) import PrettyLibHighlight (pretty,nest,text,(<>)) import HighlightStyle (cls,goto,cleareol,highlight,Highlight(..)) import Maybe import System import List (isSuffixOf,group,groupBy) import IO (hSetBuffering,BufferMode(..),stdin) import FFI resetSystem :: IO () resetSystem = do availableLines <- catch (do l <- getEnv "LINES" return (read l)) (\e-> return 25) putStr (goto 1 availableLines) System.system ("stty -cbreak echo") return () main = do System.system ("stty cbreak -echo") hSetBuffering stdin NoBuffering args <- System.getArgs hatfile <- case args of (f:_) -> return (rectify f) _ -> do putStrLn ("hat-explore: no trace file") resetSystem exitWith (ExitFailure 1) (Just trace) <- openTrace hatfile output <- readOutputFile hatfile withCString hatfile openBridgeFile bridge <- readBridgeFile trace case args of [f,"-remote",n] -> remote trace (read n) _ -> begin output bridge where begin :: String -> [HatNode] -> IO () begin output bridge = do root <- chooseFromOutput output bridge loop [(length (lines output)+4, root)] where loop stack = do stack' <- selectSubExpr stack case stack' of [] -> begin output bridge _ -> loop stack' remote :: HatTrace -> Int -> IO () remote tr n = do putStr (highlight [Bold] ("Trail: "++ replicate 72 '-')) let root = mkHatNode tr n loop [(2,root)] where loop stack = do stack' <- selectSubExpr stack case stack' of [] -> do resetSystem; exitWith ExitSuccess _ -> loop stack' rectify :: FilePath -> FilePath rectify f | ".hat" `isSuffixOf` f = f | otherwise = f ++ ".hat" readOutputFile :: FilePath -> IO String readOutputFile hat = do readFile (hat++".output") readBridgeFile :: HatTrace -> IO [HatNode] readBridgeFile tr = do vs <- until (==0) getBridgeValue return (map (mkHatNode tr) vs) where until :: (a->Bool) -> IO a -> IO [a] until pred action = do v <- action if pred v then return [] else do vs <- until pred action return (v:vs) -- Auxiliary for collecting values from the bridge file. foreign import openBridgeFile :: CString -> IO () foreign import getBridgeValue :: IO Int {- -- Allow the user to select a redex trail starting from the program output. chooseFromOutput :: String -> [HatNode] -> IO HatNode chooseFromOutput str nodes = do putStrLn (cls ++ goto 1 1 ++ highlight [Bold] ("Output: " ++ replicate 71 '-')) putStrLn str putStr (highlight [Bold] ("Trail: "++ replicate 72 '-')) i <- select 0 (1,2) [] return (nodes!!i) where select :: Int -> (Int,Int) -> [Int] -> IO Int select i (x,y) xs = do putStr (goto x y) c <- getCommand case c of L -> if i==0 then select 0 (x,y) xs else let (x',y',xs') = if str!!(i-1) == '\n' then (head xs, y-1, tail xs) else (x-1,y,xs) in select (i-1) (x',y') xs' R -> if i==length str then select i (x,y) xs else let (x',y',xs') = if str!!i == '\n' then (1,y+1,x:xs) else (x+1,y,xs) in select (i+1) (x',y') xs' Select -> return i Exit -> do resetSystem exitWith ExitSuccess _ -> select i (x,y) xs -} -- Allow the user to select a redex trail starting from the program output. chooseFromOutput :: String -> [HatNode] -> IO HatNode chooseFromOutput str nodes = do putStrLn (cls ++ goto 1 1 ++ highlight [Bold] ("Output: " ++ replicate 71 '-')) putStrLn str putStr (highlight [Bold] ("Trail: "++ replicate 72 '-')) i <- select 0 return (nodes!!i) where select :: Int -> IO Int select i = do putStr (goto 1 2 ++ location i clumpStrs) c <- getCommand case c of L -> if i==0 then select 0 else select (i-1) R -> if i==max then select max else select (i+1) Select -> return i Exit -> do resetSystem exitWith ExitSuccess _ -> select i clumpNodes = map head (group nodes) clumpStrs = map (map fst) (groupBy (\(_,n) (_,m)-> n==m) (zip str nodes)) location i xs = let (as,bs) = splitAt i xs in concat as ++ highlight [ReverseVideo] (head bs) ++ concat (tail bs) max = length clumpStrs - 1 -- Allow the user to select a subexpression from the given expression. selectSubExpr :: [(Int,HatNode)] -> IO [(Int,HatNode)] selectSubExpr stack@((lineno,node):_) = loop node (Sctx exp []) where exp = hatRep2SExp True True node -- first create an S-expr loop node ctx = do let doc = sExp2Doc node exp -- paint S-expr as a Doc str = pretty 78 (text "-> " <> nest 3 doc) -- highlighting current extent = length (lines str) -- subtree node putStrLn (goto 1 lineno ++ str) interpret node ctx extent interpret node ctx extent = do c <- getCommand case c of R -> let ctx'@(Sctx e _) = moveSelection R ctx in loop (label e) ctx' L -> let ctx'@(Sctx e _) = moveSelection L ctx in loop (label e) ctx' Select -> let (Sctx e _) = ctx in return ((lineno+extent, hatParent (label e)):stack) Delete -> do mapM_ (\n-> putStr (goto 1 n++cleareol)) [lineno..lineno+extent] return (tail stack) Exit -> do resetSystem exitWith ExitSuccess _ -> interpret node ctx extent -- An S-expression context is the means of navigation through an expression. -- It contains the "current" node, and a stack of parent nodes, each with -- an annotation to say which child of that parent is on the direct path from -- the root to the current node. data Sctx = Sctx (SExp HatNode) [(Int, SExp HatNode)] moveSelection :: Cmd -> Sctx -> Sctx moveSelection R (Sctx s ctx) = if arity s > 0 then Sctx (child 0 s) ((0,s): ctx) else unwindr ctx where unwindr [] = Sctx s ctx unwindr ((i,p):ctx) = let i' = i+1 in if i' < arity p then Sctx (child i' p) ((i',p):ctx) else unwindr ctx moveSelection L (Sctx s ctx) = unwindl ctx where unwindl [] = Sctx s [] unwindl ((i,p):ctx) = let i' = i-1 in if i > 0 then Sctx (child i' p) ((i',p):ctx) else Sctx p ctx -- A simple command interpreter. data Cmd = L | R | Select | Delete | Exit | Other getCommand :: IO Cmd getCommand = do c <- getChar case c of 'l' -> return L 'r' -> return R 'x' -> return Exit 'q' -> return Exit '\n' -> return Select '\DEL' -> return Delete '\BS' -> return Delete '\ESC' -> do c <- getChar case c of '[' -> do c <- getChar case c of 'D' -> return L 'C' -> return R _ -> return Other _ -> return Other _ -> return Other