module Main where -- HatTrail main program import LowLevel (openHatFile,openBridgeFile,getBridgeValue ,FileNode(..),nil,peekTrace,getResult ,getErrorLoc,getErrorMessage ,getSrcRef,srcRefFile,srcRefLine,srcRefCol ,getDefnRef,defnFile,defnLine,defnCol) import SExp (SExp(..),fileNode2SExp,sExp2Doc,arity,child,label ,rebuild,children,parent,funId,funLabel) import PrettyLibHighlight (pretty,nest,text,(<>)) import qualified PrettyLibHighlight as Pretty (highlight) import HighlightStyle (goto,cls,clearDown,clearUp,cleareol,highlightOff ,highlight,Highlight(..),Colour(..) ,enableScrollRegion,getTerminalSize ,savePosition,restorePosition) import Monad (when) import System (system,getArgs,getEnv,exitWith,ExitCode(..)) import Directory (doesFileExist) import List (isPrefixOf,isSuffixOf,group,groupBy) import IO (hSetBuffering,BufferMode(..),stdin,stdout,stderr ,hPutStrLn,hFlush) import Numeric (readDec,showHex) import FFI -- The recurring state within the main loop of the program contains -- the .hat filename, the terminal width and height, preferred -- highlighting styles, etc. data State = State { file :: FilePath -- .hat filename , width :: Int -- terminal screen size , height :: Int -- terminal screen size , startLine :: Int -- first line of the trail pane , styleNew :: [Highlight] -- highlight for current subexpr , styleOld :: [Highlight] -- highlight for previous subexprs , cycles :: Bool -- show cycles in the graph? , verbose :: Bool -- show unevaluated stuff in full? , eqnMode :: Bool -- always show equations? , srcrefs :: Bool -- always show src references? , cutoff :: Int -- expression cutoff depth } emptyState :: State emptyState = State { cycles=True, verbose=False, eqnMode=False , srcrefs=True, cutoff=10 } setState :: Mode -> State -> State setState (UnevalInFull b) state = state {verbose=b} setState (Cycles b) state = state {cycles=b} setState (Equations b) state = state {eqnMode=b} setState (SrcRefs b) state = state {srcrefs=b} setState (CutOff n) state = state {cutoff=max n 1} setState (Deeper n) state = state {cutoff=cutoff state + n} setState (Shallower n) state = state {cutoff=max (cutoff state - n) 1} -- The main hat-trail program main = do args <- System.getArgs hatfile <- case args of (f:_) -> return (rectify f) _ -> do hPutStrLn stderr ("hat-trail: no trace file") exitWith (ExitFailure 1) withCString hatfile openHatFile errloc <- getErrorLoc errmsg <- getErrorMessage output <- readOutputFile hatfile withCString hatfile openBridgeFile bridge <- readBridgeFile (style0,style1) <- catch (do home <- getEnv "HOME" f <- readFile (home++"/.hattrailrc") return (read f)) (\e-> return ( [Dim,Foreground Red] , [Bold,Foreground Magenta] )) (columns,lines) <- getTerminalSize let state = emptyState { file=hatfile, width=columns, height=lines , styleOld=style0, styleNew=style1 } System.system ("stty cbreak -echo") hSetBuffering stdin NoBuffering case args of [f,"-remote",n] -> remote state (read n) _ -> begin state errloc errmsg output (map peekTrace bridge) where begin :: State -> FileNode -> String -> String -> [FileNode] -> IO () begin state errloc errmsg output bridge = do (state',root) <- chooseFromOutput state errloc errmsg output bridge let res = getResult root if eqnMode state then if res == nil then loop state' [( startLine state' , Sctx (SEquation nil (toSExp state root) (SBottom res)) [])] else loop state' [( startLine state' , Sctx (SEquation nil (toSExp state root) (toSExp state res)) [])] else loop state' [ (startLine state', Sctx (toSExp state root) []) ] where loop state stack = do repaint state stack (state',stack') <- selectSubExpr state stack case stack' of [] -> begin state' errloc errmsg output bridge _ -> loop state' stack' remote :: State -> Int -> IO () remote state root = do putStr (highlight [Bold] ("Trail: "++ replicate (width state - 8) '-')) let node = FileNode root res = getResult node if eqnMode state then if res==nil then loop state{startLine=2} [( 2 , Sctx (SEquation nil (toSExp state node) (SBottom res)) [] )] else loop state{startLine=2} [( 2 , Sctx (SEquation nil (toSExp state node) (toSExp state res)) [] )] else loop state{startLine=2} [(2, Sctx (toSExp state node) [])] where loop state stack = do repaint state stack (state', stack') <- selectSubExpr state stack case stack' of [] -> do resetSystem state exitWith ExitSuccess _ -> loop state' stack' rectify :: FilePath -> FilePath rectify f | ".hat" `isSuffixOf` f = f | otherwise = f ++ ".hat" readOutputFile :: FilePath -> IO String readOutputFile hat = do readFile (hat++".output") readBridgeFile :: IO [FileNode] readBridgeFile = do until (==nil) getBridgeValue 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) -- Restore the terminal before quitting resetSystem :: State -> IO () resetSystem state = do putStr (enableScrollRegion 1 (height state)) putStr (goto 1 (height state)) System.system ("stty -cbreak echo") return () -- Conversion of a filenode to an S-expression toSExp state = fileNode2SExp (cutoff state) (cycles state) (verbose state) -- Allow the user to select a redex trail starting from the program output. -- This implementation allows movement one clump of characters at a time, -- where the clumps are based on having the same trace pointer. chooseFromOutput :: State -> FileNode -> String -> String -> [FileNode] -> IO (State,FileNode) chooseFromOutput state errloc errmsg output bridge = do putStr (cls ++ goto 1 1) when (isError) (do putStrLn (highlight [Bold] ("Error: "++replicate (width state-8) '-')) putStrLn errmsg) when (not (null output)) (do putStrLn (highlight [Bold] ("Output: "++replicate (width state-9) '-'))) -- putStrLn output) putStr (goto 1 (startLine-1)) putStr (highlight [Bold] ("Trail: "++replicate (width state-8) '-')) (state',i) <- select state{startLine=startLine} 0 putStr (enableScrollRegion startLine (height state')) return (state', clumpNodes!!i) where select :: State -> Int -> IO (State,Int) select st i = do putStr (location i (styleNew st) clumpStrs ++ goto 1 startLine) c <- getCommand st case c of Movement L -> if i==0 then select st 0 else select st (i-1) Movement Up -> if i==0 then select st 0 else select st (i-1) Movement R -> if i==max then select st max else select st (i+1) Movement Down -> if i==max then select st max else select st (i+1) Select -> do putStr (location i (styleOld st) clumpStrs) return (st,i) Status -> do showCurrentSettings st select st i Set m -> do st' <- newSetting m st select st' i Help -> do showHelp st putStr (goto 1 startLine ++ clearDown) select st i Quit -> do resetSystem st exitWith ExitSuccess _ -> select st i isError = errloc /= nil lenError = if not isError then 0 else length (lines errmsg) + 1 lenOutput = if null output then 0 else length (lines output) + 1 startLine = lenError + chunkSize + 3 chunkSize = let chunk = height state `div` 3 in if lenOutput > chunk then chunk else lenOutput max = length clumpStrs - 1 clumpNodes = (if isError then (errloc:) else id) $ map head (group bridge) -- clumpStrs = (if isError then ((errmsg ++ goto 1 (1+lenError)):) else id) $ -- map (showNL . map fst) -- (groupBy (\(_,n) (_,m)-> n==m) (zip output bridge)) clumpStrs = (if isError then (errmsg:) else id) $ beginOutput $ map (showNL . map fst) (groupBy (\(_,n) (_,m)-> n==m) (zip output bridge)) location i style [] = "" location i style xs = let (as,bs) = splitAt i xs size = if isError && i<=chunkSize then 1+chunkSize else chunkSize in goto 1 2 ++ safeUnlines (take size (trim size (lines (concat as)) ++ lines ((highlight style (head bs)) ++ concat (tail bs)))) ++ highlightOff trim :: Int -> [String] -> [String] trim n pref = if length pref >= n then beginOutput (trim n (drop n pref)) else pref safeUnlines [] = [] safeUnlines (x:xs) = (if length x > 80 then take 76 x ++ "...\n" else x++"\n") ++ safeUnlines xs showNL [] = [] showNL ('\n':cs) = '\\':'n':'\n': showNL cs showNL (c:cs) = c: showNL cs beginOutput [] = [] beginOutput (s:ss) = (goto 1 (2+lenError) ++ s): ss -- 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 FileNode) [(Int, SExp FileNode)] getRoot :: Sctx -> SExp FileNode getRoot (Sctx s []) = s getRoot (Sctx _ xs) = let (_,r) = last xs in r -- Allow the user to select a subexpression from the given expression. -- Takes a stack of previous full expressions, and returns a new stack, -- either pushing the new subexpression, or popping an old one. selectSubExpr :: State -> [(Int,Sctx)] -> IO (State,[(Int,Sctx)]) selectSubExpr state stack@((lineno,sctx@(Sctx e _)):_) = loop (label e) sctx where loop node ctx@(Sctx e _) = do let exp = getRoot ctx -- first find the root of the S-expr doc = sExp2Doc (verbose state) high exp -- paint S-expr as a Doc str = pretty (width state - 2) -- highlighting current (text "<- " <> nest 3 doc) -- subtree node len = length (lines str) extent = lineno + len high v = if v==node then Pretty.highlight (styleNew state) else id -- when (extent > height state) (repaint state (tail stack)) -- putStr (goto 1 lineno ++ str ++ goto 1 lineno) let realLineNo = if extent <= height state then lineno else height state - len when (srcrefs state) (showSrcRef e state) putStr (goto 1 realLineNo ++ str ++ goto 1 realLineNo) interpret node ctx extent interpret node ctx@(Sctx e ctx') extent = do c <- getCommand state case c of Quit -> do resetSystem state exitWith ExitSuccess Movement m -> do let newctx@(Sctx exp _) = moveSelection m ctx when (srcrefs state) (showSrcRef exp state) loop (label exp) newctx Select -> let par = parent e in if par == nil then do statusLine "no parent" state interpret node ctx extent else let res = getResult par in if eqnMode state then if res==nil then return (state, ((extent, Sctx (SEquation nil (toSExp state par) (SBottom res)) []) : (lineno, ctx): tail stack)) else return (state, ((extent, Sctx (SEquation nil (toSExp state par) (toSExp state res)) []) : (lineno, ctx): tail stack)) else return (state, ((extent, Sctx (toSExp state par) []) : (lineno, ctx): tail stack)) Delete -> let stack' = case ctx of Sctx (SEquation _ lhs rhs) ctx' | not (eqnMode state) -> (lineno,Sctx lhs ctx'):tail stack Sctx _ [(_, SEquation _ lhs rhs)] -> (lineno,Sctx lhs []):tail stack _ -> tail stack in do -- if extent >= height state -- then repaint state stack' -- else putStr (goto 1 lineno ++ clearDown) return (state,stack') Shrink -> do putStr (goto 1 lineno ++ clearDown) loop (label e) (Sctx (cut node e) (map (\(i,e)->(i,cut node e)) ctx')) Expand -> do putStr (goto 1 lineno ++ clearDown) loop (label e) (Sctx (join state node e) (map (\(i,e)->(i,join state node e)) ctx')) Detect -> do System.system (hatDetect (file state) node) interpret node ctx extent Trail -> do System.system (hatTrail (file state) node) interpret node ctx extent ObserveAll -> do System.system (hatObserve (file state) (funId e)) interpret node ctx extent ObserveSrc -> do let srcref = expSrcRef e when (srcref /= nil) (do System.system (hatObserve (file state) (srcRefFile srcref ++" "++show (srcRefLine srcref) ++" "++show (srcRefCol srcref))) return ()) interpret node ctx extent Repaint -> do repaint state stack loop node ctx Resize -> resize state stack Source -> do let srcref = expSrcRef e when (srcref /= nil) (do System.system (hatView (srcRefFile srcref) (srcRefLine srcref) (srcRefCol srcref)) showSrcRef e state) interpret node ctx extent Definition -> let defn = getDefnRef (funLabel e) in if defn==nil then do statusLine (funId e++": defn not available") state interpret node ctx extent else do ok <- doesFileExist (defnFile defn) if not ok then statusLine (funId e++": defn not found") state else do System.system (hatView (defnFile defn) (defnLine defn) (defnCol defn)) statusLine (funId e++": definition") state interpret node ctx extent Result -> let r = getRoot ctx in case r of SEquation _ lhs rhs -> do putStr (goto 1 lineno ++ clearDown) loop (label lhs) (Sctx lhs []) _ -> let res = getResult (label r) in -- if res==nil then do -- statusLine "rhs of equation not available" state -- interpret node ctx extent -- else if res==nil then let bot = SBottom (FileNode 1) in loop node (Sctx r [(0, SEquation nil r bot)]) else let rhs = toSExp state res in loop res (Sctx rhs [(1, SEquation nil r rhs)]) Status -> do showCurrentSettings state interpret node ctx extent Set mode -> do state' <- newSetting mode state let rootlabel = case getRoot ctx of SEquation _ lhs rhs -> label lhs expr -> label expr return ( state' , ( ( lineno , Sctx (toSExp state' rootlabel) [] ) : tail stack)) Help -> do showHelp state repaint state stack loop node ctx _ -> interpret node ctx extent -- To shrink or expand the current node in the S-expression, we must -- shrink or expand it at every level in the context path as well. cut :: Eq a => a -> SExp a -> SExp a cut v exp = let l = label exp in if l==v then SCut v else rebuild exp (map (cut v) (children exp)) join :: State -> FileNode -> SExp FileNode -> SExp FileNode join state v exp = let l = label exp in if l==v then toSExp state v else rebuild exp (map (join state v) (children exp)) -- Movement within the S-expression tree can be specified in a couple of -- different ways: -- Pre-order traversal: -- R: if a branch, go down and left -- if a leaf, go up and right -- L: if a branch, go up, left, and down to the right -- if a leaf, go up, left, and down to the right -- Level navigation: -- Up: go to the enclosing expr (if there is one) -- Down: go to the first interior subexpression (if there is one) -- JumpR: go one expr to the right within the enclosing expr -- JumpL: go one expr to the left within the enclosing expr moveSelection :: Cursor -> 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 windr (child i' p) ((i',p):ctx) else Sctx p ctx windr p ctx = let rhs = (arity p) - 1 in if rhs >= 0 then windr (child rhs p) ((rhs,p):ctx) else Sctx p ctx moveSelection JumpR ctx@(Sctx _ []) = ctx moveSelection JumpL ctx@(Sctx _ []) = ctx moveSelection JumpR ctx@(Sctx s ((i,p):ctx')) = let i' = i+1 in if i' < arity p then Sctx (child i' p) ((i',p):ctx') else ctx moveSelection JumpL ctx@(Sctx s ((i,p):ctx')) = let i' = i-1 in if i > 0 then Sctx (child i' p) ((i',p):ctx') else ctx moveSelection Up ctx@(Sctx _ []) = ctx moveSelection Up (Sctx _ ((i,p):ctx')) = Sctx p ctx' moveSelection Down ctx@(Sctx s ctx') = if arity s > 0 then Sctx (child 0 s) ((0,s):ctx') else ctx moveSelection ListLeft (Sctx s ((0,SApp _ (SId _ ":" _ : _)) :(1, p@(SApp _ (SId _ ":" _ : hd: tl))) :ctx')) = Sctx hd ((0,p):ctx') moveSelection ListRight (Sctx s ((0,p'@(SApp _ (SId _ ":" _ : _: p@(SApp _ (SId _ ":" _ : hd: tl)):_))) :ctx')) = Sctx hd ((0,p):(1,p'):ctx') moveSelection ListLeft ctx | otherwise = ctx moveSelection ListRight ctx | otherwise = ctx -- Repaint screen, or possibly start afresh and follow the same path -- through the trails (e.g. save state and restore?) repaint :: State -> [(Int,Sctx)] -> IO () {- -- This implementation repaints the entire trail. It starts at the -- top of the screen and writes downwards. At the bottom of the screen, -- new stuff causes old stuff to get scrolled upwards. repaint state stack = do putStr (goto 1 (startLine state) ++ clearDown) paint state (reverse stack) where paint state [] = return () paint state (i@(lineno,ctx@(Sctx node _)):stack) = let exp = getRoot ctx -- first find the root of the S-expr doc = sExp2Doc (verbose state) high exp -- paint S-expr as a Doc str = pretty (width state - 2) -- highlighting current (text "<- " <> nest 3 doc) -- subtree node extent = lineno + length (lines str) high v = if v == label node then Pretty.highlight (styleOld state) else id in do if (extent > height state) then putStrLn str else putStrLn (goto 1 lineno ++ str) paint state stack -} -- This implementation of `repaint' tries to calculate only what -- is visible on screen, rather than repainting the entire trail. -- It starts painting at the bottom of the screen and goes upwards -- until the screen is full, then stops. repaint state [] = do putStr (goto 1 (startLine state) ++ clearDown) repaint state (top:stack) = do putStr (goto 1 (startLine state) ++ clearDown) extent <- paintOne (styleNew state) maxBegin top -- extent = where last item ends mapM_ (paint extent) stack where maxBegin = fst top -- = where last item starts available = height state - startLine state -- how much screen space? paint max i@(lineno,_) = do if max < height state -- everything fits on screen? then paintOne (styleOld state) lineno i else let newpos = available - (max-lineno) in if newpos < 0 then return 0 -- this item is off the top else paintOne (styleOld state) (startLine state + newpos) i -- this item fits return () paintOne style lineno (_, ctx@(Sctx node _)) = let exp = getRoot ctx -- first find the root of the S-expr doc = sExp2Doc (verbose state) high exp -- paint S-expr as a Doc str = pretty (width state - 2) -- highlighting current (text "<- " <> nest 3 doc) -- subtree node extent = lineno + length (lines str) high v = if v == label node then Pretty.highlight style else id in do putStrLn (goto 1 lineno ++ str) return extent -- Repaint the screen following a resizing of the terminal. This means -- we need to recalculate all the line numbers, and we must repaint the -- entire trail. resize :: State -> [(Int,Sctx)] -> IO (State,[(Int,Sctx)]) resize state stack = do (columns,lines) <- getTerminalSize let state' = state {width=columns,height=lines} putStr (enableScrollRegion (startLine state') (height state')) putStr (goto 1 (startLine state') ++ clearDown) stack' <- paint state' (startLine state') [] (reverse stack) return (state',stack') where paint state _ acc [] = return acc paint state lineno acc ((_,ctx@(Sctx node _)):stack) = let exp = getRoot ctx -- first find the root of the S-expr doc = sExp2Doc (verbose state) high exp -- paint S-expr as a Doc str = pretty (width state - 2) -- highlighting current (text "<- " <> nest 3 doc) -- subtree node extent = lineno + length (lines str) high v = if v == label node then Pretty.highlight (styleOld state) else id in do if (extent > height state) then putStrLn str else putStrLn (goto 1 lineno ++ str) paint state extent ((lineno,ctx):acc) stack expSrcRef :: SExp FileNode -> FileNode expSrcRef (SEquation _ lhs rhs) = expSrcRef lhs expSrcRef exp = getSrcRef (label exp) showSrcRef :: SExp FileNode -> State -> IO () showSrcRef exp state = let srcref = expSrcRef exp in if srcref == nil then statusLine "no src reference" state else statusLine (srcRefFile srcref ++" line: "++show (srcRefLine srcref) ++" col: "++show (srcRefCol srcref)) state statusLine :: String -> State -> IO () statusLine "" state = do putStr (savePosition ++ goto 30 (startLine state - 1) ++ highlight [Bold] (replicate 48 '-') ++ restorePosition) statusLine msg state = do putStr (savePosition ++ goto 30 (startLine state - 1) ++ ' ': take 46 msg ++ " " ++ highlight [Bold] (replicate (max 0 (46 - length msg)) '-') ++ restorePosition) hFlush stdout showCurrentSettings :: State -> IO () showCurrentSettings state = do statusLine (plusminus cycles "cycles" ++ plusminus verbose " verbose" ++ plusminus eqnMode " eqns" ++ " cutoff="++show (cutoff state)) state where plusminus f s = s++(if f state then "(+)" else "(-)") newSetting :: Mode -> State -> IO State newSetting mode state = do let state' = setState mode state showCurrentSettings state' System.system ("sleep 1") return state' -- A simple key-stroke interpreter. data Cmd = Movement Cursor | Select | Delete | Shrink | Expand | Result | Source | Definition | Detect | Trail | ObserveAll | ObserveSrc | Quit | Unknown | Help | Repaint | Resize | Set Mode | Status data Cursor = L | R | JumpL | JumpR | Up | Down | ListLeft | ListRight data Mode = UnevalInFull Bool | Cycles Bool | Equations Bool | SrcRefs Bool | CutOff Int | Deeper Int | Shallower Int getCommand :: State -> IO Cmd getCommand state = do c <- getChar case c of 'x' -> return Quit '\n' -> return Select '\DEL' -> return Delete '\BS' -> return Delete '-' -> return Shrink '+' -> return Expand '=' -> return Result '<' -> return (Movement JumpL) '>' -> return (Movement JumpR) ',' -> return (Movement JumpL) -- unshifted < '.' -> return (Movement JumpR) -- unshifted > '[' -> return (Movement ListLeft) ']' -> return (Movement ListRight) '\^L' -> return Repaint '\^R' -> return Resize '\ESC' -> do c <- getChar case c of '[' -> do c <- getChar case c of 'D' -> return (Movement L) 'C' -> return (Movement R) 'A' -> return (Movement Up) 'B' -> return (Movement Down) _ -> return Unknown 'O' -> do c <- getChar case c of 'D' -> return (Movement L) 'C' -> return (Movement R) 'A' -> return (Movement Up) 'B' -> return (Movement Down) _ -> return Unknown _ -> return Unknown ':' -> do putStr (savePosition ++ goto 1 (height state)++":") cmd <- colonCmd 1 "" putStr (goto 1 (height state) ++ cleareol ++ restorePosition) return cmd _ -> return Unknown -- a specialised input mode on the bottom line of the screen for ':' commands colonCmd :: Int -> String -> IO Cmd colonCmd 0 _ = return Unknown colonCmd n s = do let (w:ws) = words (reverse s) c <- getChar case c of '\n' | null s -> return Unknown | w `isPrefixOf` "source" -> return Source | w `isPrefixOf` "Source" -> return Definition | w `isPrefixOf` "set" -> case ws of [] -> return Status (m:ss) | m `isPrefixOf` "verbose" -> return (onOff UnevalInFull ss) | m `isPrefixOf` "cycles" -> return (onOff Cycles ss) | m `isPrefixOf` "eqns" -> return (onOff Equations ss) | m `isPrefixOf` "equations" -> return (onOff Equations ss) | m `isPrefixOf` "srcrefs" -> return (onOff SrcRefs ss) | m `isPrefixOf` "cutoff" -> return (Set (CutOff (safeRead 10 (unwords ss)))) | w `isPrefixOf` "observe" -> return ObserveAll | w `isPrefixOf` "location" -> return ObserveSrc | w `isPrefixOf` "trail" -> return Trail | w `isPrefixOf` "detect" -> return Detect | w `isPrefixOf` "quit" -> return Quit | w `isPrefixOf` "help" -> return Help | head w == '?' -> return Help | head w == '+' -> return (Set (Deeper (safeRead 1 (tail w)))) | head w == '-' -> return (Set (Shallower (safeRead 1 (tail w)))) | otherwise -> return Unknown where (w:ws) = words (reverse s) '\DEL' -> do putStr "\DEL \DEL" colonCmd (n-1) (tail s) '\BS' -> do putStr "\BS \BS" colonCmd (n-1) (tail s) _ -> do putChar c colonCmd (n+1) (c:s) -- onOff parses whether an option should be turned on or off onOff :: (Bool->Mode) -> [String] -> Cmd onOff mode s | null s = Set (mode True) | otherwise = case head s of "on" -> Set (mode True) "active" -> Set (mode True) "off" -> Set (mode False) "no" -> Set (mode False) _ -> Unknown --safeRead takes a default value to return if the parse is not successful safeRead :: Int -> String -> Int safeRead d s = case readDec s of [] -> d ((n,_):_) -> n -- Links to other hat-tools hatObserve :: FilePath -> String -> String hatObserve f i = "xterm -e hat-observe-T "++f++" -remote "++i++" &" hatDetect :: FilePath -> FileNode -> String hatDetect f n = "xterm -e hat-detect-T "++f++" -remote "++show (int n)++" &" hatTrail :: FilePath -> FileNode -> String hatTrail f n = "xterm -e hat-trail-T "++f++" -remote "++show (int n)++" &" hatView :: FilePath -> Int -> Int -> String hatView f y x = "xterm -e hat-view "++f++" "++show y++" "++show x++" &" -- Help text is painted to screen here, but erased by the caller. showHelp :: State -> IO () showHelp state = do statusLine "keystrokes/commands available" state putStr (goto 1 (startLine state) ++ clearDown) putStr helpText putStr (highlight [Bold] (replicate (width state - 1) '-')) _ <- getChar return () where helpText = "\ \ cursor keys movement within current expression\n\ \ < and > keys movement within current expression\n\ \ RETURN show parent expression of selected expression\n\ \ BACKSPACE remove most recently-added expression/equation\n\ \ -/+ shrink/expand a cutoff expression\n\ \ ^L repaint the display if it gets corrupted\n\ \ ^R repaint the display after resizing the window\n\ \ :source look at the source-code application of this expression\n\ \ :Source look at the source-code definition of current function\n\ \ :observe use hat-observe to find all applications of this function\n\ \ :location use hat-observe to find all applications at this call site\n\ \ :trail start a fresh hat-trail with the current expression\n\ \ :detect use hat-detect to debug the current expression\n\ \ :set show all current mode settings\n\ \ :set change one mode setting\n\ \ can be: verbose [on|off]: unevaluated expressions shown in full\n\ \ equations [on|off]: show equations, not just redexes\n\ \ cycles [on|off]: cope with cyclic structures\n\ \ cutoff : cut-off depth for deeply nested exprs\n\ \ :+[n] shortcut to increase cutoff depth\n\ \ :-[n] shortcut to decrease cutoff depth\n\ \ :help :? show this help text\n\ \ :quit quit\n"