import HatTrace import HatTrie import HatExpressionTree import PrettyExp(showReduction) import HighlightStyle (cursorUp,cleareol,highlight,Highlight(..),Colour(..)) import Maybe import List(sort,isPrefixOf) import Monad(when) import System import Char(isDigit,digitToInt,toUpper) import IO(hFlush,stdout) --import NodeMatch spawnDetectCmd = "xterm -e hat-detect-T " spawnDetectEnd = "&" spawnJavaCmd = "hat-trail-in-java " spawnJavaEnd = "&" spawnTrailCmd = "xterm -e hat-trail-T " spawnTrailEnd = "&" shortHelpText = ":h for help, :q to quit" ----------------------------------------------------------------------- -- misc functions ----------------------------------------------------------------------- checkParameters :: String -> String -> Int checkParameters l ('-':r) = checkParameters' l r where checkParameters' _ [] = 0 checkParameters' l (c:r) = if c `elem` l then checkParameters' l r else 2 checkParameters _ _ = 1 hasBadParameters :: String -> [String] -> Bool hasBadParameters flags params = foldl (\y x-> x==2 || y) False (map (checkParameters flags) params) goodParameters :: String -> [String] -> String goodParameters flags l = concat (filter (\x-> checkParameters flags x ==0) l) noParameters :: [String] -> [String] noParameters l = filter (\x-> checkParameters [] x ==1) l checkIdentifiers (ident1:"in":ident2:file:[]) = Just (ident1,ident2,file) checkIdentifiers (ident1:file:[]) = Just (ident1,"",file) checkIdentifiers (file:[]) = Just ("","",file) checkIdentifiers _ = Nothing main = do arguments <- getArgs -- putStrLn ("cmdline args: "++show arguments) if length arguments ==3 && head (tail arguments) == "-remote" then startObserve (head arguments) False False False (head (drop 2 arguments)) "" True else if length arguments == 5 && head (tail arguments) == "-remote" then startObserveSrc (head arguments) (tail (tail arguments)) else let identifiers = checkIdentifiers (noParameters arguments); options = (goodParameters "vxur" arguments) in if isNothing identifiers || hasBadParameters "vxur" arguments then do -- putStrLn ("identifiers: "++show identifiers) putStrLn ("hasBadParameters: " ++show (hasBadParameters "vxur" arguments)) putStrLn cmdlineHelp else let verboseMode = 'v' `elem` options recursiveMode = 'r' `elem` options expertMode = 'x' `elem` options (ident1,ident2,file) = fromJust identifiers in startObserve file verboseMode recursiveMode expertMode ident1 ident2 False --startObserve :: String -> Bool -> Bool -> Bool -> String -> String -> Bool -- -> IO () startObserve file verboseMode recursiveMode expertMode ident1 ident2 remote = do maybehattrace <- openTrace file when (isNothing maybehattrace) (do putStrLn ("hat-observe: Error: cannot open file \""++file++"\".") exitWith (ExitFailure 1)) let hattrace = fromJust maybehattrace when (remote || (ident1=="")) (putStrLn ("\n hat-observe "++hatVersionNumber ++" ("++shortHelpText++")\n")) let observed = if remote || (ident1/="") then makeObserve hattrace recursiveMode expertMode False False (\x->True) ident1 ident2 else Found [] if ident1=="" then do dummy <- interactive (file,hattrace) (State {lastObserved = [] ,more = False ,equationsPerPage = 10 ,currentPos = 0 ,cutoffdepth = 10 ,observable = observableIdents hattrace ,verboseMode = False ,recursiveMode = True ,generaliseMode = False}) return () else if remote then do let obs = fromFound observed hasmore = (null obs)==False when (hasmore==False) (putStrLn ("\nNo evaluated applications of \""++ident1 ++"\" found\n")) dummy <- doCommand More (file,hattrace) (State {lastObserved = fromFound observed ,more = hasmore ,equationsPerPage = 10 ,currentPos = 0 ,cutoffdepth = 10 ,observable = observableIdents hattrace ,verboseMode = False ,recursiveMode = True ,generaliseMode = False}) return () else if isInterrupted observed then putStrLn "{Interrupted}" else if isTopIdentNotFound observed then putStrLn ("Sorry, nothing recorded in trace about " ++"identifier \""++ident2++"\".\n(Check spelling?)") else if isIdentNotFound observed then putStrLn ("Sorry, nothing recorded in trace about " ++"identifier \""++ident1++"\".\n(Check spelling?)") else do showObservationList verboseMode 20 1 100000 (fromFound observed) -- printCReductionList 100 (fromFound observed) return () startObserveSrc file args = do maybehattrace <- openTrace file when (isNothing maybehattrace) (do putStrLn ("hat-observe: Error: cannot open file \""++file++"\".") exitWith (ExitFailure 1)) let hattrace = fromJust maybehattrace putStrLn ("\n hat-observe "++hatVersionNumber ++" ("++shortHelpText++")\n") let observed = makeObserveSrc hattrace args obs = fromFound observed when (null obs) (putStrLn "\nNo evaluated applications found at source reference") dummy <- doCommand More (file,hattrace) (State {lastObserved = fromFound observed ,more = not (null obs) ,equationsPerPage = 10 ,currentPos = 0 ,cutoffdepth = 10 ,observable = observableIdents hattrace ,verboseMode = False ,recursiveMode = True ,generaliseMode = False}) return () showObservables :: [HatNode] -> IO () showObservables l = showObservables' 0 "" (sort (map hatName l)) where showObservables' n _ [] = if ((n-1) `mod` 3 == 2) then return () else putChar '\n' showObservables' n preceeding (o:obs) = if (preceeding/=o) then do putStr (take 26 (" "++o++" ")) if (n `mod` 3 == 2) then putChar '\n' else return () showObservables' (n+1) o obs else showObservables' n o obs observableIdents :: HatTrace -> [HatNode] observableIdents hattrace = let r = observables hattrace; f = (fromFound r) in if isFound r then -- return all identifiers filter (\x -> ((hatNodeType x)==HatIdentNode)) f else [] showObservation :: Bool -> Int -> Int -> HatNode -> IO () showObservation verboseMode cutoffdepth i node = do putStr (cursorUp ++ cleareol) -- delay relies on line-buffered output putStr $ showReduction verboseMode cutoffdepth node (highlight [Foreground Blue] (show i++" ")) "\n" -- arguments to showObservationList are: -- verboseMode :: Bool show ungeneralised equations? -- cutoffdepth :: Int depth of nested expression cut-off -- i :: Int numbered equation -- max :: Int how many equations to show at once -- exprs :: [HatNode] roots of equations -- result is number of equations that have been shown showObservationList :: Bool -> Int -> Int -> Int -> [HatNode] -> IO Int showObservationList _ _ _ _ [] = do putStr (cursorUp ++ cleareol); return 0 showObservationList _ _ i 0 _ = do putStr (cursorUp ++ cleareol); return 0 showObservationList verboseMode cutoffdepth i max (e:r) = do showObservation verboseMode cutoffdepth i e putStrLn ("searching: (^C to interrupt)") count <- showObservationList verboseMode cutoffdepth (i+1) (max-1) r return (count+1) makeObserve :: HatTrace -> Bool -> Bool -> Bool -> Bool -> (LinExpr->Bool) -> String -> String -> ObserveResult makeObserve hattrace recursiveMode expertMode filterMode generaliseMode filterFun ident1 ident2 = let observed = observe hattrace ident1 ident2 recursiveMode in if isFound observed then if expertMode then observed else if filterMode then Found (uniqueFilter generaliseMode (fromFound observed) filterFun) else Found (myunique generaliseMode (fromFound observed)) else observed makeObserveSrc :: HatTrace -> [String] -> ObserveResult makeObserveSrc hattrace [mod,line,col] | all isDigit line && all isDigit col = observeSrc hattrace mod (fromJust (stringToInt line)) (fromJust (stringToInt col)) makeObserveSrc hattrace _ | otherwise = IdentNotFound {- not quite sure what the difference between these two functions -- for determining unique equations is. -} myunique :: Bool -> [HatNode] -> [HatNode] myunique generaliseMode observed = unique' observed [] where unique' [] tries = if generaliseMode then getTrieNodes tries else [] unique' (obs:observed) trie = let (b,tries) = insertTrie trie (linearizeEquation (toHatExpressionTree 200 obs)); r = unique' observed tries in if generaliseMode then r else if b then (obs:r) else r uniqueFilter :: Bool -> [HatNode] -> (LinExpr -> Bool) -> [HatNode] uniqueFilter generaliseMode observed filterFun = uniqueFilter' observed [] where uniqueFilter' [] tries = if generaliseMode then getTrieNodes tries else [] uniqueFilter' (obs:observed) trie = let linexpr = linearizeEquation (toHatExpressionTree 200 obs); (b,tries) = if filterFun linexpr then insertTrie trie linexpr else (False,trie); r = uniqueFilter' observed tries in if generaliseMode then r else if b then (obs:r) else r {- This is a replacement unique-ifier which uses simple tree comparison -- rather than tries. Not yet implemented. -} uniqueify :: InteractiveState -> [HatNode] -> [HatNode] uniqueify state nodes | generaliseMode state = nodes | otherwise = -- let eqns = map (fileNode2SExp.toFileNode) nodes in nodes -- not implemented yet last2 :: [a] -> ([a],[a]) last2 [] = ([],[]) last2 (a:b:[]) = ([a,b],[]) last2 (a:list) = let (last,whole) = last2 list in (last, a:whole) {- options :: String -> (String,String) options s = let w = words s; dropFun = (\ x->((length x)>0)&&((head x)=='-')); o = takeWhile dropFun w; r = dropWhile dropFun w in ((unwords o),(unwords r)) -} showSomeMore :: InteractiveState -> IO (Int,Bool) showSomeMore state = let showNowList = drop (currentPos state) (lastObserved state); hasMore = not (null (drop (equationsPerPage state) showNowList)) in do putStrLn ("searching: (^C to interrupt)") count <- showObservationList (verboseMode state) (cutoffdepth state) (currentPos state + 1) (equationsPerPage state) showNowList return (count + currentPos state, hasMore) interactive :: (String,HatTrace) -> InteractiveState -> IO () interactive hatfile state | more state = do putStr "--more--> " hFlush stdout cmd <- getCommand case cmd of Observe _ -> interactive hatfile state{more=False} _ -> doCommand cmd hatfile state | otherwise = do putStr "hat-observe> " hFlush stdout cmd <- getCommand doCommand cmd hatfile state getEquationNumber :: Int -> [HatNode] -> IO (Maybe HatNode) getEquationNumber n lastObserved = let nodes = drop (n-1) lastObserved in if n>0 then if null nodes then do -- This test may take a while! putStrLn "No equation with this number" return Nothing else return (Just (head nodes)) else return Nothing ---- data InteractiveState = State { lastObserved :: [HatNode] , more :: Bool , equationsPerPage :: Int , currentPos :: Int , cutoffdepth :: Int , observable :: [HatNode] , verboseMode :: Bool , recursiveMode :: Bool , generaliseMode:: Bool } setState :: Mode -> InteractiveState -> InteractiveState setState (Verbose b) state = state {verboseMode=b} setState (Recursive b) state = state {recursiveMode=b} setState (Generalise b) state = state {generaliseMode=b} setState (CutOff n) state = state {cutoffdepth=max n 1} setState (Deeper n) state = state {cutoffdepth=cutoffdepth state + n} setState (Shallower n) state = state {cutoffdepth=max (cutoffdepth state - n) 1} setState (Group n) state = state {equationsPerPage=max n 1} showState (Verbose _) state = " "++highlight [Underscore] "verbose" ++ " mode is " ++if verboseMode state then "active" else "off" showState (Recursive _) state = " "++highlight [Underscore] "recursive" ++ " calls are " ++ (if recursiveMode state then "" else "NOT ") ++ "shown" showState (Generalise _) state = " "++ highlight [Underscore] "generalise" ++ " equations mode is " ++ if generaliseMode state then "active" else "off" showState (CutOff _) state = " expression " ++ highlight [Underscore] "cutoff" ++ " depth = "++ show (cutoffdepth state) showState (Deeper _) state = showState (CutOff 0) state showState (Shallower _) state = showState (CutOff 0) state showState (Group _) state = " equations per " ++ highlight [Underscore] "group" ++ " = "++ show (equationsPerPage state) ---- doCommand :: Cmd -> (String,HatTrace) -> InteractiveState -> IO() doCommand Help hatfile state = do interactiveHelp interactive hatfile state doCommand Quit hatfile state = if more state then interactive hatfile state{more=False} else return () doCommand More hatfile state = if more state then do putStr (cursorUp ++ cleareol) (newPos,newMore) <- showSomeMore state interactive hatfile (state {more=newMore,currentPos=newPos}) else do when (currentPos state>0) (putStrLn "No more applications observed.") interactive hatfile state doCommand Info hatfile state = do showObservables (observable state) interactive hatfile state doCommand Count hatfile state = do when (more state) (putStrLn "One moment, this may take a while...") putStrLn ("Number of unique matching applications: " ++(show (length (lastObserved state)))) interactive hatfile state doCommand Status hatfile state = do mapM_ (\m-> putStrLn (showState m state)) [Generalise True,Verbose True,Recursive True,Group 0,CutOff 0] interactive hatfile state doCommand (Set mode) hatfile state = do let state' = setState mode state putStrLn (showState mode state') interactive hatfile state' doCommand (StartTool tool n) hatfile@(file,_) state = do node <- getEquationNumber n (lastObserved state) when (isJust node) (startExternalTool tool file n (fromJust node)) interactive hatfile state doCommand (Observe s) hatfile state | null s = do putStrLn "\nObserve Wizard" putStrLn "" putStr "enter function to be observed: " hFlush stdout fun <- getLine putStrLn "" if (fun=="") then do putStrLn "nothing to be observed" interactive hatfile state else do putStrLn "You can observe applications with specific arguments only." putStrLn "The '_' matches any subexpression." putStrLn "Enter specific arguments separated by spaces, or leave blank." putStr "arguments: " hFlush stdout arguments <- getLine putStrLn "" putStrLn "You can observe applications which result in a specific pattern." putStrLn "_|_ represents a blackholed result." putStr "result (or leave blank): " result <- getLine putStrLn "" putStrLn ("You can observe applications of \""++fun ++"\" within the context of ") putStrLn "specific second function only." putStr "Enter second function (or leave blank): " ident2 <- getLine putStrLn "" rekMode <- if (ident2/="") then return "" else do putStr ("Do you want to observe recursive calls of "++fun++"? Y/N:") hFlush stdout rek <- getLine putStrLn "" if ((null rek)==False)&&((toUpper (head rek))=='N') then return "-r " else return "" let query = "o "++rekMode++ (if null arguments then fun else ("("++fun++" "++arguments++")"))++ (if null result then "" else (" = "++result))++ (if null ident2 then "" else (" in "++ident2)) putStrLn ("Your query is: "++query++"\n") doCommand (Observe query) hatfile state doCommand (Observe s) hatfile@(_,hattrace) state | not (null s) = let (pattern1, pattern2) = break (=="in") (stringLex s) (pattern, patternError) = stringLinExpr pattern1 inpattern = if null pattern2 then "" else pattern2!!1 fun = lmoFun pattern in if not (null patternError) then do putStrLn ("ERROR in pattern: "++patternError) interactive hatfile state else if length pattern2 > 2 then do putStrLn ("ERROR: pattern 'in' pattern is not permitted,\ \ only pattern 'in' ident") interactive hatfile state else do putStrLn ("searching: (^C to interrupt)") let newObserved = makeObserve hattrace (recursiveMode state) False (length pattern > 2) (generaliseMode state) (\x -> (compareExpr x pattern)) fun inpattern if isTopIdentNotFound newObserved || isIdentNotFound newObserved || null (fromFound newObserved) then do putStrLn (cursorUp ++ cleareol ++ "no match found") interactive hatfile state else do putStr (cursorUp ++ cleareol) (newPos,newMore) <- showSomeMore (state { currentPos=0 , lastObserved=fromFound newObserved}) interactive hatfile (state {lastObserved=fromFound newObserved ,more=newMore ,currentPos=newPos}) doCommand (ObserveSrc ss) hatfile@(_,hattrace) state = do putStr "searching for source reference: (^C to interrupt)" let newObserved = makeObserveSrc hattrace ss if isTopIdentNotFound newObserved || isIdentNotFound newObserved || null (fromFound newObserved) then do putStrLn (cursorUp ++ cleareol ++"no match found") interactive hatfile state else do putStr (cursorUp ++ cleareol) (newPos,newMore) <- showSomeMore (state { currentPos=0 , lastObserved=fromFound newObserved}) interactive hatfile (state {lastObserved=fromFound newObserved ,more=newMore ,currentPos=newPos}) doCommand Unknown hatfile state = do putStrLn ("Unknown command. "++shortHelpText) interactive hatfile state startExternalTool tool file number node = let id = toRemoteRep node; rhsID = toRemoteRep (hatResult node) in case tool of Choose -> do putStr "start hat-detect or hat-trail? (D/T): " s <- getLine let choice = case map toUpper s of "D"->Detect; "T"->Trail; "J"->Java; _ ->Choose; startExternalTool choice file number node Java -> do putStr ("Equation "++(show number) ++": Trace left-hand-side (lhs) or rhs of equation? (L/R): ") lhs <- getLine errcode <- system (spawnJavaCmd++file++" -remote " ++(if rhsID=="" || length lhs==0 || toUpper (head lhs) /='R' then id else rhsID) ++spawnJavaEnd) when (errcode/=ExitSuccess) (putStrLn ("ERROR: Unable to start hat-trail-in-java.\n" ++"Check settings and availability.")) Trail -> do errcode <- system (spawnTrailCmd++file++" -remote "++id ++spawnTrailEnd) when (errcode/=ExitSuccess) (putStrLn ("ERROR: Unable to start hat-trail.\n" ++"Check settings and availability of hat-trail.")) Detect -> do errcode <- system (spawnDetectCmd++file++" -remote " ++id++spawnDetectEnd) when (errcode/=ExitSuccess) (putStrLn ("ERROR: Unable to start hat-detect.\n" ++"Check settings and availability of hat-detect.")) interactiveHelp = do putStr helptext s <- getLine when (null s) (putStrLn queryHelp) where helptext = "\ \---------------------------------------------------------------------------\n\ \ observe the named function/pattern (syntax below)\n\ \ show more observations (if available)\n\ \ :observe observe the named function/pattern (syntax below)\n\ \ :info see a list of all observable functions\n\ \ :detect start hat-detect on equation \n\ \ :trail start hat-trail browser on equation \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\ \ generalise [on|off]: show only most general equations\n\ \ recursive [on|off]: show recursive calls\n\ \ group : number of equations listed per page\n\ \ cutoff : cut-off depth for deeply nested exprs\n\ \ :+[n] short-cut to increase cutoff depth by (default 1)\n\ \ :-[n] short-cut to decrease cutoff depth by (default 1)\n\ \ :help :? show this help text\n\ \ :quit quit\n\ \---------------------------------------------------------------------------" queryHelp = "\ \ The syntax of an :observe .\n\ \ A simple function identifier finds all applications of that function.\n\ \ To restrict the number of equations, follow the function name with\n\ \ argument or result patterns. Another way of refining the search is\n\ \ to ask for calls only from a specific enclosing function.\n\ \\n\ \ The full query syntax is:\n\ \ identifier [pattern]* ['=' pattern]? ['in' identifier]?\n\ \ where\n\ \ pattern = _ wildcard\n\ \ | ''' char ''' character\n\ \ | '\"' string '\"' string\n\ \ | num number\n\ \ | '[' pattern [',' pattern]* ']' literal list\n\ \ | Constr nullary constructor\n\ \ | '(' Constr [pattern]* ')' constructor application\n\ \ Note: Currently INFIX operators are not supported in patterns.\n\ \ Please use prefix style and enclose applications in parentheses.\n\ \ Examples:\n\ \ myfunction\n\ \ myfunction _ (MyConstructor 2 _) in myOtherFunction\n\ \ (myfunction \"Hello World!\" (: 1 (: 2 _))) = [1,_]\n\ \---------------------------------------------------------------------------" cmdlineHelp = "\ \Usage: hat-observe prog[.hat]\n\ \ An interactive tool to show actual function applications within\n\ \ a traced run of a Haskell program." {- cmdlineHelp = "\ \Usage: hat-observe [-v] [-r] [-xu] identifier [in topidentifier] filename\n\ \Description:\n\ \ prints a table of all applications and results of the given\n\ \ top-level identifier [within the application of topidentifier].\n\ \Options:\n\ \ v: verbose mode. Unevaluated expressions are shown in full.\n\ \ r: recursive mode. Do not omit recursive function applications.\n\ \ xu: expert's mode for a very fast response. All applications\n\ \ of the identifier are shown, rather than only the most\n\ \ general ones." -} data Cmd = Observe String | ObserveSrc [String] | More | Info | Count | Help | Quit | Unknown | StartTool Tool Int | Status | Set Mode data Tool = Trail | Java | Detect | Choose data Mode = Generalise Bool | Verbose Bool | Recursive Bool | CutOff Int | Deeper Int | Shallower Int | Group Int getCommand :: IO Cmd getCommand = do s <- getLine if null s then return More -- else if all isDigit s then return (number (StartTool Choose) [s] 0) else if head s /= ':' then return (Observe s) else case words (tail s) of [] -> return Unknown (cmd:ss) | cmd `isPrefixOf` "quit" -> return Quit | cmd `isPrefixOf` "help" -> return Help | cmd `isPrefixOf` "observe" -> return (Observe (unwords ss)) | cmd `isPrefixOf` "location" -> return (ObserveSrc ss) | cmd `isPrefixOf` "detect" -> return (number (StartTool Detect) ss 0) | cmd `isPrefixOf` "trail" -> return (number (StartTool Trail) ss 0) | cmd `isPrefixOf` "java" -> return (number (StartTool Java) ss 0) | cmd `isPrefixOf` "info" -> return Info | cmd `isPrefixOf` "set" -> case ss of [] -> return Status (m:sss) | m `isPrefixOf` "verbose" -> return (onOff Verbose sss) | m `isPrefixOf` "generalise" -> return (onOff Generalise sss) | m `isPrefixOf` "recursive" -> return (onOff Recursive sss) | m `isPrefixOf` "cutoff" -> return (Set (number CutOff sss 10)) | m `isPrefixOf` "group" -> return (Set (number Group sss 10)) | otherwise -> return Unknown | head cmd == '?' -> return Help | head cmd == '+' -> return (Set (number Deeper (tail cmd:ss) 1)) | head cmd == '-' -> return (Set (number Shallower (tail cmd:ss) 1)) | otherwise -> return Unknown number :: (Int->a) -> [String] -> Int -> a number cons s def = (maybe (cons def) cons . stringToInt . unwords) s 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 stringToInt :: String -> Maybe Int stringToInt s = stringToInt' True 0 s where stringToInt' True _ ('#':r) = stringToInt' True 0 r -- skip "#" at beginning stringToInt' True _ (' ':r) = stringToInt' True 0 r -- skip " " at beginning --stringToInt' False i (' ':r) = Just i stringToInt' first i [] = if first then Nothing else Just i stringToInt' _ i (c:r) | isDigit c = stringToInt' False (i*10+(digitToInt c)) r | otherwise = Nothing