diff --git a/Debug/Hoed.hs b/Debug/Hoed.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed.hs @@ -0,0 +1,346 @@ +{-| +Module : Debug.Hoed +Description : Lighweight algorithmic debugging based on observing intermediate values. +Copyright : (c) 2000 Andy Gill, (c) 2010 University of Kansas, (c) 2013-2017 Maarten Faddegon +License : BSD3 +Maintainer : hoed@maartenfaddegon.nl +Stability : experimental +Portability : POSIX + +Hoed is a tracer and debugger for the programming language Haskell. + +Hoed is recommended over Hoed.Stk: in contrast to Hoed.Stk you can optimize your program and do not need to enable profiling when using Hoed. + +To locate a defect with Hoed you annotate suspected functions and compile as usual. Then you run your program, information about the annotated functions is collected. Finally you connect to a debugging session using a webbrowser. + +Let us consider the following program, a defective implementation of a parity function with a test property. + +> import Test.QuickCheck +> +> isOdd :: Int -> Bool +> isOdd n = isEven (plusOne n) +> +> isEven :: Int -> Bool +> isEven n = mod2 n == 0 +> +> plusOne :: Int -> Int +> plusOne n = n + 1 +> +> mod2 :: Int -> Int +> mod2 n = div n 2 +> +> prop_isOdd :: Int -> Bool +> prop_isOdd x = isOdd (2*x+1) +> +> main :: IO () +> main = printO (prop_isOdd 1) +> +> main :: IO () +> main = quickcheck prop_isOdd + +Using the property-based test tool QuickCheck we find the counter example `1` for our property. + +> ./MyProgram +> *** Failed! Falsifiable (after 1 test): 1 + +Hoed can help us determine which function is defective. We annotate the functions `isOdd`, `isEven`, `plusOne` and `mod2` as follows: + +> import Debug.Hoed +> +> isOdd :: Int -> Bool +> isOdd = observe "isOdd" isOdd' +> isOdd' n = isEven (plusOne n) +> +> isEven :: Int -> Bool +> isEven = observe "isEven" isEven' +> isEven' n = mod2 n == 0 +> +> plusOne :: Int -> Int +> plusOne = observe "plusOne" plusOne' +> plusOne' n = n + 1 +> +> mod2 :: Int -> Int +> mod2 = observe "mod2" mod2' +> mod2' n = div n 2 +> +> prop_isOdd :: Int -> Bool +> prop_isOdd x = isOdd (2*x+1) +> +> main :: IO () +> main = printO (prop_isOdd 1) + +After running the program a computation tree is constructed and displayed in a web browser. + +> ./MyProgram +> False +> Listening on http://127.0.0.1:10000/ + +After running the program a computation tree is constructed and displayed in a +web browser. You can freely browse this tree to get a better understanding of +your program. If your program misbehaves, you can judge the computation +statements in the tree as 'right' or 'wrong' according to your intention. When +enough statements are judged the debugger tells you the location of the fault +in your code. + +<> + +Read more about Hoed on its project homepage . + +Papers on the theory behind Hoed can be obtained via . + +I am keen to hear about your experience with Hoed: where did you find it useful and where would you like to see improvement? You can send me an e-mail at hoed@maartenfaddegon.nl, or use the github issue tracker . +-} + +{-# LANGUAGE CPP #-} + +module Debug.Hoed + ( -- * Basic annotations + observe + , runO + , printO + , testO + + -- * Property-assisted algorithmic debugging + , runOwp + , printOwp + , testOwp + , Propositions(..) + , PropType(..) + , Proposition(..) + , mkProposition + , ofType + , withSignature + , sizeHint + , withTestGen + , TestGen(..) + , PropositionType(..) + , Module(..) + , Signature(..) + , ParEq(..) + , (===) + , runOstore + , conAp + + -- * Build your own debugger with Hoed + , runO' + , judge + , unjudgedCharacterCount + , CompTree(..) + , Vertex(..) + , CompStmt(..) + , Judge(..) + , Verbosity(..) + + -- * API to test Hoed itself + , logO + , logOwp + , traceOnly + , UnevalHandler(..) + + -- * The Observable class + , Observer(..) + , Observable(..) + , (<<) + , thunk + , nothunk + , send + , observeOpaque + , observeBase + , constrainBase + , debugO + , CDS(..) + , Generic + ) where + + +import Debug.Hoed.Observe +import Debug.Hoed.Render +import Debug.Hoed.EventForest +import Debug.Hoed.CompTree +import Debug.Hoed.Console +import Debug.Hoed.Prop +import Debug.Hoed.Serialize +import Paths_Hoed(getDataDir) + +import Prelude hiding (Right) +import qualified Prelude +import System.Process(system) +import System.IO +import Data.Maybe +import Control.Monad +import Data.List +import Data.Ord +import Data.Char +import System.Environment +import System.Directory(createDirectoryIfMissing) + +import GHC.Generics + +import Data.IORef +import System.IO.Unsafe +import Data.Graph.Libgraph + +import System.Directory(createDirectoryIfMissing) + + +-- %************************************************************************ +-- %* * +-- \subsection{External start functions} +-- %* * +-- %************************************************************************ + +-- Run the observe ridden code. + + +runOnce :: IO () +runOnce = do + f <- readIORef firstRun + case f of True -> writeIORef firstRun False + False -> error "It is best not to run Hoed more that once (maybe you want to restart GHCI?)" + +firstRun :: IORef Bool +firstRun = unsafePerformIO $ newIORef True + + +-- | run some code and return the Trace +debugO :: IO a -> IO Trace +debugO program = + do { runOnce + ; initUniq + ; startEventStream + ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]" + ; ourCatchAllIO (do { program ; return () }) + (hPutStrLn stderr . errorMsg) + ; endEventStream + } + +-- | The main entry point; run some IO code, and debug inside it. +-- After the IO action is completed, an algorithmic debugging session is started at +-- @http://localhost:10000/@ to which you can connect with your webbrowser. +-- +-- For example: +-- +-- @ +-- main = runO $ do print (triple 3) +-- print (triple 2) +-- @ + +runO :: IO a -> IO () +runO program = do + (trace,traceInfo,compTree,frt) <- runO' Verbose program + debugSession trace compTree [] + return () + + +-- | Hoed internal function that stores a serialized version of the tree on disk (assisted debugging spawns new instances of Hoed). +runOstore :: String -> IO a -> IO () +runOstore tag program = do + (trace,traceInfo,compTree,frt) <- runO' Silent program + storeTree (treeFilePath ++ tag) compTree + storeTrace (traceFilePath ++ tag) trace + +-- | Repeat and trace a failing testcase +testO :: Show a => (a->Bool) -> a -> IO () +testO p x = runO $ putStrLn $ if (p x) then "Passed 1 test." + else " *** Failed! Falsifiable: " ++ show x + +-- | Use property based judging. + +runOwp :: [Propositions] -> IO a -> IO () +runOwp ps program = do + (trace,traceInfo,compTree,frt) <- runO' Verbose program + let compTree' = compTree + debugSession trace compTree' ps + return () + +-- | Repeat and trace a failing testcase +testOwp :: Show a => [Propositions] -> (a->Bool) -> a -> IO () +testOwp ps p x = runOwp ps $ putStrLn $ + if (p x) then "Passed 1 test." + else " *** Failed! Falsifiable: " ++ show x + +-- | Short for @runO . print@. +printO :: (Show a) => a -> IO () +printO expr = runO (print expr) + + +printOwp :: (Show a) => [Propositions] -> a -> IO () +printOwp ps expr = runOwp ps (print expr) + +-- | Only produces a trace. Useful for performance measurements. +traceOnly :: IO a -> IO () +traceOnly program = do + debugO program + return () + + +data Verbosity = Verbose | Silent + +condPutStrLn :: Verbosity -> String -> IO () +condPutStrLn Silent _ = return () +condPutStrLn Verbose msg = hPutStrLn stderr msg + +-- |Entry point giving you access to the internals of Hoed. Also see: runO. +runO' :: Verbosity -> IO a -> IO (Trace,TraceInfo,CompTree,EventForest) +runO' verbose program = do + createDirectoryIfMissing True ".Hoed/" + condPutStrLn verbose "=== program output ===\n" + events <- debugO program + condPutStrLn verbose"\n=== program terminated ===" + condPutStrLn verbose"Please wait while the computation tree is constructed..." + + let cdss = eventsToCDS events + let cdss1 = rmEntrySet cdss + let cdss2 = simplifyCDSSet cdss1 + let eqs = renderCompStmts cdss2 + + let frt = mkEventForest events + ti = traceInfo (reverse events) + ds = dependencies ti + ct = mkCompTree eqs ds + + writeFile ".Hoed/Events" (unlines . map show . reverse $ events) +#if defined(TRANSCRIPT) + writeFile ".Hoed/Transcript" (getTranscript events ti) +#endif + + condPutStrLn verbose "\n=== Statistics ===\n" + let e = length events + n = length eqs + b = fromIntegral (length . arcs $ ct ) / fromIntegral ((length . vertices $ ct) - (length . leafs $ ct)) + condPutStrLn verbose $ show e ++ " events" + condPutStrLn verbose $ show n ++ " computation statements" + condPutStrLn verbose $ show ((length . vertices $ ct) - 1) ++ " nodes + 1 virtual root node in the computation tree" + condPutStrLn verbose $ show (length . arcs $ ct) ++ " edges in computation tree" + condPutStrLn verbose $ "computation tree has a branch factor of " ++ show b ++ " (i.e the average number of children of non-leaf nodes)" + + condPutStrLn verbose "\n=== Debug Session ===\n" + return (events, ti, ct, frt) + +-- | Trace and write computation tree to file. Useful for regression testing. +logO :: FilePath -> IO a -> IO () +logO filePath program = {- SCC "logO" -} do + (_,_,compTree,_) <- runO' Verbose program + writeFile filePath (showGraph compTree) + return () + + where showGraph g = showWith g showVertex showArc + showVertex RootVertex = ("\".\"","shape=none") + showVertex v = ("\"" ++ (escape . showCompStmt) v ++ "\"", "") + showArc _ = "" + showCompStmt = show . vertexStmt + +-- | As logO, but with property-based judging. +logOwp :: UnevalHandler -> FilePath -> [Propositions] -> IO a -> IO () +logOwp handler filePath properties program = do + (trace,traceInfo,compTree,frt) <- runO' Verbose program + hPutStrLn stderr "\n=== Evaluating assigned properties ===\n" + compTree' <- judgeAll handler unjudgedCharacterCount trace properties compTree + writeFile filePath (showGraph compTree') + return () + + where showGraph g = showWith g showVertex showArc + showVertex RootVertex = ("root","") + showVertex v = ("\"" ++ (escape . showCompStmt) v ++ "\"", "") + showArc _ = "" + showCompStmt s = (show . vertexJmt) s ++ ": " ++ (show . vertexStmt) s diff --git a/Debug/Hoed/CompTree.hs b/Debug/Hoed/CompTree.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/CompTree.hs @@ -0,0 +1,407 @@ +-- This file is part of the Haskell debugger Hoed. +-- +-- Copyright (c) Maarten Faddegon, 2015 + +{-# LANGUAGE CPP, DeriveGeneric #-} + +module Debug.Hoed.CompTree +( CompTree +, Vertex(..) +, mkCompTree +, isRootVertex +, vertexUID +, vertexRes +, replaceVertex +, getJudgement +, setJudgement +, isRight +, isWrong +, isUnassessed +, isAssisted +, isInconclusive +, isPassing +, leafs +, ConstantValue(..) +, getLocation +, unjudgedCharacterCount +#if defined(TRANSCRIPT) +, getTranscript +#endif +, TraceInfo(..) +, traceInfo +, Graph(..) -- re-export from LibGraph +)where + +import Debug.Hoed.Render +import Debug.Hoed.Observe +import Debug.Hoed.EventForest + +import Prelude hiding (Right) +import Data.Graph.Libgraph +import Data.List(nub,delete,(\\)) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import GHC.Generics + +data Vertex = RootVertex | Vertex {vertexStmt :: CompStmt, vertexJmt :: Judgement} + deriving (Eq,Show,Ord,Generic) + +getJudgement :: Vertex -> Judgement +getJudgement RootVertex = Right +getJudgement v = vertexJmt v + +setJudgement :: Vertex -> Judgement -> Vertex +setJudgement RootVertex _ = RootVertex +setJudgement v j = v{vertexJmt=j} + +isRight v = getJudgement v == Right +isWrong v = getJudgement v == Wrong +isUnassessed v = getJudgement v == Unassessed +isAssisted v = case getJudgement v of (Assisted _) -> True; _ -> False + +isInconclusive v = case getJudgement v of + (Assisted ms) -> any isInconclusive' ms + _ -> False +isInconclusive' (InconclusiveProperty _) = True +isInconclusive' _ = False + +isPassing v = case getJudgement v of + (Assisted ms) -> any isPassing' ms + _ -> False +isPassing' (PassingProperty _) = True +isPassing' _ = False + +vertexUID :: Vertex -> UID +vertexUID RootVertex = -1 +vertexUID (Vertex s _) = stmtIdentifier s + +vertexRes :: Vertex -> String +vertexRes RootVertex = "RootVertex" +vertexRes v = stmtRes . vertexStmt $ v + +-- | The forest of computation trees. Also see the Libgraph library. +type CompTree = Graph Vertex () + +isRootVertex :: Vertex -> Bool +isRootVertex RootVertex = True +isRootVertex _ = False + +leafs :: CompTree -> [Vertex] +leafs g = filter (\v -> succs g v == []) (vertices g) + +-- | Approximates the complexity of a computation tree by summing the length +-- of the unjudged computation statements (i.e not Right or Wrong) in the tree. +unjudgedCharacterCount :: CompTree -> Int +unjudgedCharacterCount = sum . (map characterCount) . (filter unjudged) . vertices + where characterCount = length . stmtLabel . vertexStmt + +unjudged = not . judged +judged v = (isRight v || isWrong v) + +replaceVertex :: CompTree -> Vertex -> CompTree +replaceVertex g v = mapGraph f g + where f RootVertex = RootVertex + f v' | (vertexUID v') == (vertexUID v) = v + | otherwise = v' + +-------------------------------------------------------------------------------- +-- Computation Tree + +-- One computation statement can have multiple result-events. Sometime these add +-- new information, often the information is just a duplicate of what we already +-- know. With nub we remove the duplicates. + +mkCompTree :: [CompStmt] -> [(UID,UID)] -> CompTree +mkCompTree cs ds = Graph RootVertex (vs) as + + where vs = RootVertex : map (\cs -> Vertex cs Unassessed) cs + as = map (\(i,j) -> Arc (findVertex i) (findVertex j) ()) (nub ds) + + -- A mapping from stmtUID to Vertex of all CompStmts in cs + vMap :: IntMap Vertex + -- vMap = foldl (\m c -> let v = Vertex c Unassessed in foldl (\m' i -> IntMap.insert i v m') m (stmtUIDs c)) IntMap.empty cs + vMap = foldl (\m c -> IntMap.insert (stmtIdentifier c) (Vertex c Unassessed) m) IntMap.empty cs + + -- Given an UID, get corresponding CompStmt (wrapped in a Vertex) + findVertex :: UID -> Vertex + findVertex (-1) = RootVertex + findVertex a = case IntMap.lookup a vMap of + Nothing -> error $ "mkCompTree: Error, cannot find a statement with UID " ++ show a ++ "!\n" + ++ "We recorded statements with the following UIDs: " ++ (show . IntMap.keys) vMap ++ "\n" + ++ unlines (map (\c -> (show . stmtIdentifier) c ++ ": " ++ show c) cs) + (Just v) -> v + +------------------------------------------------------------------------------------------------------------------------ + +data ConstantValue = ConstantValue { valStmt :: UID, valLoc :: Location + , valMin :: UID, valMax :: UID } + | CVRoot + deriving Eq + +instance Show ConstantValue where + show CVRoot = "Root" + show v = "Stmt-" ++ (show . valStmt $ v) + ++ "-" ++ (show . valLoc $ v) + ++ ": " ++ (show . valMin $ v) + ++ "-" ++ (show . valMax $ v) + +------------------------------------------------------------------------------------------------------------------------ + +-- Add element x to the head of the list at key k. +insertCon :: Int -> a -> IntMap [a] -> IntMap [a] +insertCon k x = IntMap.insertWith (\[x'] xs->x':xs) k [x] -- where x == x' + +------------------------------------------------------------------------------------------------------------------------ + +data TraceInfo = TraceInfo + { topLvlFun :: IntMap UID + -- references from the UID of an event to the UID of the corresponding top-level Fun event + , locations :: IntMap (ParentPosition -> Bool) + -- reference from parent UID and position to location + , computations :: Nesting + -- UIDs of active and paused computations of arguments/results of Fun events +#if defined(TRANSCRIPT) + , messages :: IntMap String + -- stored depth of the stack for every event +#endif + , storedStack :: IntMap [UID] + -- reference from parent UID and position to previous stack + , dependencies :: [(UID,UID)] + } -- the result + + +------------------------------------------------------------------------------------------------------------------------ +#if defined(TRANSCRIPT) +addMessage :: Event -> String -> TraceInfo -> TraceInfo +addMessage e msg s = s{ messages = (flip $ IntMap.insert i) (messages s) $ case IntMap.lookup i (messages s) of + Nothing -> msg + (Just msg') -> msg' ++ ", " ++ msg } + + where i = eventUID e + + +getMessage :: Event -> TraceInfo -> String +getMessage e s = case IntMap.lookup i (messages s) of + Nothing -> "" + (Just msg) -> msg + + where i = eventUID e + +getTranscript :: [Event] -> TraceInfo -> String +getTranscript es t = foldl (\acc e -> (show e ++ m e) ++ "\n" ++ acc) "" es + + where m e = case IntMap.lookup (eventUID e) ms of + Nothing -> "" + (Just msg) -> "\n " ++ msg + + ms = messages t +#endif +------------------------------------------------------------------------------------------------------------------------ + +getLocation :: Event -> TraceInfo -> Bool +getLocation e s = getLocation' p + + where p = parentPosition . eventParent $ e + j = (parentUID . eventParent $ e) + (Just getLocation') = (IntMap.lookup j (locations s)) + +setLocation :: Event -> (ParentPosition -> Bool) -> TraceInfo -> TraceInfo +setLocation e getLoc s = s{locations=IntMap.insert i getLoc (locations s)} + + where i = eventUID e + +------------------------------------------------------------------------------------------------------------------------ + +-- When we see a Fun event whose parent is not a Fun event it is a top level Fun event, +-- otherwise just copy the reference to the top level Fun event from the parent. +-- A top leven Fun event references itself. +seeFun :: Event -> TraceInfo -> TraceInfo +seeFun e s = s{ topLvlFun=case IntMap.lookup j (topLvlFun s) of + Nothing -> IntMap.insert i i (topLvlFun s) + (Just a) -> IntMap.insert i a (topLvlFun s) + } + + where i = eventUID e + j = parentUID . eventParent $ e + +-- Get the UID of the top-level Fun of the parent of event e +getTopLvlFun :: Event -> TraceInfo -> UID +getTopLvlFun e s = case IntMap.lookup j (topLvlFun s) of Nothing -> j; (Just a') -> a' + + where j = parentUID . eventParent $ e + +-- Copy top-level Fun reference from the parent of e +cpyTopLvlFun :: Event -> TraceInfo -> TraceInfo +cpyTopLvlFun e s = s{topLvlFun=IntMap.insert i a (topLvlFun s)} + + where i = eventUID e + a = getTopLvlFun e s + +------------------------------------------------------------------------------------------------------------------------ + +data Span = Computing UID | Paused UID +type Nesting = [Span] + +instance Show Span where + show (Computing i) = show i + show (Paused i) = "(" ++ show i ++ ")" + +showCs :: [Span] -> String +showCs [] = "< >" +showCs [c] = "< " ++ show c ++ " >" +showCs (c:cs) = foldl (\s c' -> s ++ ", " ++ show c') ("< " ++ show c) cs ++ " >" + +getSpanUID (Computing j) = j +getSpanUID (Paused j) = j + +isSpan :: UID -> Span -> Bool +isSpan i s = i == getSpanUID s + +start :: Event -> TraceInfo -> TraceInfo +start e s = m s{computations = cs} + + where i = getTopLvlFun e s + cs = Computing i : computations s +#if defined(TRANSCRIPT) + m = addMessage e $ "Start computation " ++ show i ++ ": " ++ showCs cs +#else + m = id +#endif + + +stop :: Event -> TraceInfo -> TraceInfo +stop e s = m s{computations = cs} + + where i = getTopLvlFun e s + cs = deleteFirst (computations s) + deleteFirst [] = [] + deleteFirst (s:ss) | isSpan i s = ss + | otherwise = s : deleteFirst ss +#if defined(TRANSCRIPT) + m = addMessage e $ "Stop computation " ++ show i ++ ": " ++ showCs cs +#else + m = id +#endif + + +pause :: Event -> TraceInfo -> TraceInfo +pause e s = m s{computations=cs} + + where i = getTopLvlFun e s + cs = case cs_post of + [] -> cs_pre + (c:cs') -> cs_pre ++ (Paused i) : cs' + (cs_pre,cs_post) = break isComputingI (computations s) + isComputingI (Computing j) = i == j + isComputingI _ = False +#if defined(TRANSCRIPT) + m = addMessage e $ "Pause computation " ++ show i ++ ": " ++ showCs cs +#else + m = id +#endif + +resume :: Event -> TraceInfo -> TraceInfo +resume e s = m s{computations=cs} + + where i = getTopLvlFun e s + cs = case cs_post of + [] -> cs_pre + (c:cs') -> cs_pre ++ (Computing i) : cs' + (cs_pre,cs_post) = break isPausedI (computations s) + isPausedI (Paused j) = i == j + isPausedI _ = False +#if defined(TRANSCRIPT) + m = addMessage e $ "Resume computation " ++ show i ++ ": " ++ showCs cs +#else + m = id +#endif + +activeComputations :: TraceInfo -> [UID] +activeComputations s = map getSpanUID . filter isActive $ computations s + where isActive (Computing _) = True + isActive _ = False + + +------------------------------------------------------------------------------------------------------------------------ + +addDependency :: Event -> TraceInfo -> TraceInfo +addDependency e s = m s{dependencies = case d of (Just d') -> d':dependencies s; Nothing -> dependencies s} + + where d = case activeComputations s of + [] -> Nothing + [n] -> Just (-1,n) -- top-level function detected (may later add dependency from Root) + (n:m:_) -> Just (m,n) + +#if defined(TRANSCRIPT) + m = case d of + Nothing -> addMessage e ("does not add dependency") + (Just d') -> addMessage e ("adds dependency " ++ show (fst d') ++ " -> " ++ show (snd d')) +#else + m = id +#endif + +------------------------------------------------------------------------------------------------------------------------ + +type ConsMap = IntMap [ParentPosition] + +-- Iff an event is a constant then the UID of its parent and its ParentPosition +-- are elements of the ConsMap. +mkConsMap :: Trace -> ConsMap +mkConsMap = foldl loop IntMap.empty + where loop :: IntMap [ParentPosition] -> Event -> IntMap [ParentPosition] + loop m e = case change e of + Cons{} -> insertCon (parentUID . eventParent $ e) (parentPosition . eventParent $ e) m + _ -> m + +-- Return True for an enter event corresponding to a constant event and for any constant event, return False otherwise. +corToCons :: ConsMap -> Event -> Bool +corToCons cs e = case IntMap.lookup j cs of + Nothing -> False + (Just ps) -> p `elem` ps + where j = (parentUID . eventParent $ e) + p = parentPosition . eventParent $ e + +------------------------------------------------------------------------------------------------------------------------ + +traceInfo :: Trace -> TraceInfo +traceInfo trc = foldl loop s0 trc + + where s0 :: TraceInfo + s0 = TraceInfo IntMap.empty IntMap.empty [] +#if defined(TRANSCRIPT) + IntMap.empty +#endif + IntMap.empty [] + + cs :: ConsMap + cs = mkConsMap trc + + loop :: TraceInfo -> Event -> TraceInfo + loop s e = let loc = getLocation e s + in case change e of + Observe{} -> setLocation e (\_->True) s + + Fun{} -> setLocation e (\q->case q of 0 -> not loc; 1 -> loc) + . seeFun e $ s + + -- Span start + Enter{} -> if not . corToCons cs $ e then s else cpyTopLvlFun e + $ case loc of + True -> addDependency e + $ start e s + False -> pause e s + + NoEnter{} -> if not . corToCons cs $ e then s else cpyTopLvlFun e + $ case loc of + True -> addDependency e + $ start e s + False -> pause e s + + -- Span end + Cons{} -> cpyTopLvlFun e + . setLocation e (\_->loc) + $ case loc of + True -> stop e s + False -> resume e s diff --git a/Debug/Hoed/Console.hs b/Debug/Hoed/Console.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Console.hs @@ -0,0 +1,180 @@ +-- This file is part of the Haskell debugger Hoed. +-- +-- Copyright (c) Maarten Faddegon, 2014-2017 +{-# LANGUAGE CPP #-} +module Debug.Hoed.Console(debugSession) where +import qualified Prelude +import Prelude hiding(Right) +import Debug.Hoed.ReadLine +import Debug.Hoed.Observe +import Debug.Hoed.Render +import Debug.Hoed.CompTree +import Debug.Hoed.Prop +import Debug.Hoed.Serialize +import Text.Regex.Posix.String as Regex +import Text.Regex.Posix +import Text.Regex.Posix.String +import Data.Graph.Libgraph +import Data.List(findIndex,intersperse,nub,sort,sortBy +#if __GLASGOW_HASKELL__ >= 710 + , sortOn +#endif + ) + +#if __GLASGOW_HASKELL__ < 710 +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = map snd . sortOn' fst . map (\x -> (f x, x)) + +sortOn' :: Ord b => (a -> b) -> [a] -> [a] +sortOn' f = sortBy (\x y -> compare (f x) (f y)) +#endif + + +debugSession :: Trace -> CompTree -> [Propositions] -> IO () +debugSession trace tree ps = + case filter (not . isRootVertex) $ vs of + [] -> putStrLn $ "No functions annotated with 'observe' expressions" + ++ "or annotated functions not evaluated" + (v:_) -> do noBuffering + mainLoop v trace tree ps + where + (Graph _ vs _) = tree + +-------------------------------------------------------------------------------- +-- main menu + +mainLoop :: Vertex -> Trace -> CompTree -> [Propositions] -> IO () +mainLoop cv trace compTree ps = do + i <- readLine "hdb> " ["adb", "observe", "help"] + case words i of + ["adb"] -> adb cv trace compTree ps + ["observe", regexp] -> do printStmts compTree regexp; loop + ["observe"] -> do printStmts compTree ""; loop + ["exit"] -> return () + _ -> do help; loop + where + loop = mainLoop cv trace compTree ps + +help :: IO () +help = putStr + $ "help Print this help message.\n" + ++ "observe [regexp] Print computation statements that match the regular\n" + ++ " expression. Omitting the expression prints all statements.\n" + ++ "adb Start algorithmic debugging.\n" + ++ "exit leave debugging session\n" + +-------------------------------------------------------------------------------- +-- observe + +printStmts :: CompTree -> String -> IO () +printStmts (Graph _ vs _) regexp = do + rComp <- Regex.compile defaultCompOpt defaultExecOpt regexp + case rComp of Prelude.Left (_, errorMessage) -> printL errorMessage + Prelude.Right _ -> printR + where + printL errorMessage = putStrLn errorMessage + printR + | vs_filtered == [] = printL $ "There are no computation statements matching \"" ++ regexp ++ "\"." + | otherwise = printStmts' vs_filtered + vs_filtered + | regexp == "" = vs_sorted + | otherwise = filter (\v -> (noNewlines . vertexRes $ v) =~ regexp) vs_sorted + vs_sorted = sortOn (vertexRes) . filter (not . isRootVertex) $ vs + +printStmts' :: [Vertex] -> IO () +printStmts' vs = do + mapM_ print (zip [1..] vs) + putStrLn "--------------------------------------------------------------------" + where + print (n,v) = do + putStrLn $ "--- stmt-" ++ show n ++ " ------------------------------------------" + (putStrLn . show . vertexStmt) v + +-------------------------------------------------------------------------------- +-- algorithmic debugging + +adb :: Vertex -> Trace -> CompTree -> [Propositions] -> IO () +adb cv trace compTree ps = do + adb_stats compTree + print $ vertexStmt cv + case lookupPropositions ps cv of + Nothing -> adb_interactive cv trace compTree ps + (Just prop) -> do + judgement <- judge trace prop cv unjudgedCharacterCount compTree + case judgement of + (Judge Right) -> adb_judge cv Right trace compTree ps + (Judge Wrong) -> adb_judge cv Wrong trace compTree ps + (Judge (Assisted msgs)) -> adb_advice msgs cv trace compTree ps + (AlternativeTree newCompTree newTrace) -> do + putStrLn "Discovered simpler tree!" + let cv' = next RootVertex newCompTree + adb cv' newTrace newCompTree ps + +adb_advice msgs cv trace compTree ps = do + mapM_ putStrLn (map toString msgs) + adb_interactive cv trace compTree ps + where + toString (InconclusiveProperty s) = "inconclusive property: " ++ s + toString (PassingProperty s) = "passing property: " ++ s + +adb_interactive cv trace compTree ps = do + i <- readLine "? " ["right", "wrong", "prop", "exit"] + case i of + "right" -> adb_judge cv Right trace compTree ps + "wrong" -> adb_judge cv Wrong trace compTree ps + "exit" -> mainLoop cv trace compTree ps + _ -> do adb_help + adb cv trace compTree ps + + + +adb_help :: IO () +adb_help = putStr + $ "help Print this help message.\n" + ++ "right Judge computation statements right according to the\n" + ++ " intentioned behaviour/specification of the function\n" + ++ "wrong Judge computation statements wrong according to the\n" + ++ " intentioned behaviour/specification of the function\n" + ++ "exit Return to main menu\n" + +adb_stats :: CompTree -> IO () +adb_stats compTree = putStrLn + $ "======================================================================= [" + ++ show (length vs_w) ++ "-" ++ show (length vs_r) ++ "/" ++ show (length vs) ++ "]" + where + vs = filter (not . isRootVertex) (vertices compTree) + vs_r = filter isRight vs + vs_w = filter isWrong vs + + +adb_judge :: Vertex -> Judgement -> Trace -> CompTree -> [Propositions] -> IO () +adb_judge cv jmt trace compTree ps = case faultyVertices compTree' of + (v:_) -> do adb_stats compTree' + putStrLn $ "Fault located! In:\n" ++ vertexRes v + mainLoop cv trace compTree' ps + [] -> adb cv_next trace compTree' ps + where + cv_next = next cv' compTree' + compTree' = mapGraph replaceCV compTree + replaceCV v = if vertexUID v === vertexUID cv' then cv' else v + cv' = setJudgement cv jmt + +faultyVertices :: CompTree -> [Vertex] +faultyVertices = findFaulty_dag getJudgement + +next :: Vertex -> CompTree -> Vertex +next v ct = case getJudgement v of + Right -> up + Wrong -> down + _ -> v + where + (up:_) = preds ct v + (down:_) = filter unjudged (succs ct v) + +unjudged :: Vertex -> Bool +unjudged = unjudged' . getJudgement + where + unjudged' Right = False + unjudged' Wrong = False + unjudged' _ = True + diff --git a/Debug/Hoed/EventForest.hs b/Debug/Hoed/EventForest.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/EventForest.hs @@ -0,0 +1,147 @@ +-- This file is part of the Haskell debugger Hoed. +-- +-- Copyright (c) Maarten Faddegon, 2015 + +module Debug.Hoed.EventForest +( EventForest(..) +, mkEventForest +, parentUIDLookup +, parentPosLookup + +, InfixOrPrefix(..) +, Location(..) +, Visit +, dfsFold +, idVisit + +, treeUIDs +, topLevelApps +, eventsInTree +, dfsChildren +, elems +) where +import Debug.Hoed.Observe +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +-- Searchable mapping from UID of the parent and position in list of siblings +-- to a child event. +-- type EventForest = [(UID, [(ParentPosition, Event)])] +type EventForest = IntMap [(ParentPosition, Event)] + +isRoot :: Event -> Bool +isRoot e = case change e of Observe{} -> True; _ -> False + +elems :: EventForest -> [[(ParentPosition, Event)]] +elems = IntMap.elems + +addEvent :: EventForest -> Event -> EventForest +addEvent frt e + | isRoot e = frt + | otherwise = IntMap.insert i s frt + where i = parentUID . eventParent $ e + p = parentPosition . eventParent $ e + ms = IntMap.lookup i frt + s = case ms of Nothing -> [(p,e)] + (Just s') -> (p,e) : s' + + +mkEventForest :: Trace -> EventForest +mkEventForest trc = foldl addEvent IntMap.empty trc + +parentUIDLookup :: UID -> EventForest -> [(ParentPosition,Event)] +parentUIDLookup i frt = case IntMap.lookup i frt of + Nothing -> [] + (Just es) -> es + +parentPosLookup :: ParentPosition -> [(ParentPosition,Event)] -> [Event] +parentPosLookup p = map snd . filter ((==p) . fst) + +data InfixOrPrefix = Infix | Prefix + +data Location = Trunk | ArgumentOf Location | ResultOf Location | FieldOf Int Location + deriving Eq + +instance Show Location where + show Trunk = "" + show (ArgumentOf loc) = 'a' : show loc + show (ResultOf loc) = 'r' : show loc + show (FieldOf n loc) = 'f' : show n ++ show loc + +type Visit a = Maybe Event -> Location -> a -> a + +idVisit :: Visit a +idVisit _ _ z = z + +-- Given an event, return the list of (expected) children in depth-first order. +-- +-- Nothing indicates that we expect an event (e.g. the argument of an application- +-- event) but it was not there. +-- +-- An abstraction (LamEvent) can have more than one application. There is no +-- particular ordering and we just return the applications (AppEvents) in the +-- order we find them in the trace (i.e. evaluation order). + +dfsChildren :: EventForest -> Event -> [Maybe Event] +dfsChildren frt e = case change e of + Enter{} -> manyByPosition 0 -- Should be Nothing? + (Cons l _) -> foldl (\acc x -> acc ++ manyByPosition x) [] [0..(l-1)] + Observe{} -> manyByPosition 0 + Fun -> manyByPosition 0 ++ manyByPosition 1 + + where manyByPosition :: ParentPosition -> [Maybe Event] + manyByPosition pos = case filter (\(pos',_) -> pos == pos') cs of + [] -> [Nothing] + ts -> map (Just . snd) ts + + -- Events in the frt that list our event as parent (in no particular order). + cs :: [(ParentPosition,Event)] + cs = parentUIDLookup (eventUID e) frt + + +dfsFold :: InfixOrPrefix -> Visit a -> Visit a -> a + -> Location -> (Maybe Event) -> EventForest -> a + +dfsFold ip pre post z loc me frt + = post me loc $ case me of + Nothing -> z' + (Just e) -> case change e of + + Fun -> let [arg,res] = cs + in case ip of + Prefix -> csFold $ zip cs [ArgumentOf loc,ArgumentOf loc,ResultOf loc,ResultOf loc] + + Infix -> let z1 = dfsFold ip pre post z (ArgumentOf loc) arg frt + z2 = pre me loc z1 + in dfsFold ip pre post z2 (ResultOf loc) res frt + + Cons{} -> csFold $ zip cs $ map (\i -> FieldOf i loc) [1..] + + _ -> csFold $ zip cs (repeat loc) + + where z' = pre me loc z + + cs :: [Maybe Event] + cs = case me of (Just e) -> dfsChildren frt e; Nothing -> error "dfsFold filter failed" + + csFold = foldl (\z'' (c,loc') -> dfsFold ip pre post z'' loc' c frt) z' + +treeUIDs :: EventForest -> Event -> [UID] +treeUIDs frt = (map eventUID) . eventsInTree frt + +-- Given an event r, return depth first ordered list of events in the (sub)tree starting from r. +eventsInTree :: EventForest -> Event -> [Event] +eventsInTree frt r = reverse $ dfsFold Prefix add idVisit [] Trunk (Just r) frt + where add (Just e) _ es = e : es + add Nothing _ es = es + +-- Find all toplevel AppEvents for RootEvent r +topLevelApps :: EventForest -> Event -> [Event] +topLevelApps frt r = foldl appendApp [] $ dfsChildren frt r + +appendApp :: [Event] -> Maybe Event -> [Event] +appendApp z me = case me of + Nothing -> z + (Just e) -> case change e of Fun -> e : z + _ -> z + diff --git a/Debug/Hoed/NoTrace.hs b/Debug/Hoed/NoTrace.hs deleted file mode 100644 --- a/Debug/Hoed/NoTrace.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-| -Module : Debug.Hoed.Notrace -Description : Lighweight algorithmic debugging based on observing intermediate values. -Copyright : (c) 2016 Maarten Faddegon -License : BSD3 -Maintainer : hoed@maartenfaddegon.nl -Stability : experimental -Portability : POSIX - -Hoed is a tracer and debugger for the programming language Haskell. - -This is a drop-in replacement of the Debug.Hoed.Pure or Debug.Hoed.Stk modules and disables tracing (all functions are variations of id). - -Read more about Hoed on its project homepage . - -Papers on the theory behind Hoed can be obtained via . - -I am keen to hear about your experience with Hoed: where did you find it useful and where would you like to see improvement? You can send me an e-mail at hoed@maartenfaddegon.nl, or use the github issue tracker . --} - -{-# LANGUAGE DefaultSignatures, CPP #-} - -module Debug.Hoed.NoTrace -( observe -, runO -, printO -, testO -, observeBase -, Observable(..) -, Parent(..) -, Generic(..) -, send -, ObserverM(..) -, (<<) -) where -import GHC.Generics -import System.IO.Unsafe -import Control.Monad - -observe :: String -> a -> a -observe _ = id - -runO :: IO a -> IO () -runO program = do - program - return () - -printO :: (Show a) => a -> IO () -printO expr = print expr - -testO :: Show a => (a->Bool) -> a -> IO () -testO p x = putStrLn $ if (p x) then "Passed 1 test." - else " *** Failed! Falsifiable: " ++ show x - -data Parent = Parent -class Observable a where - observer :: a -> Parent -> a - default observer :: (Generic a) => a -> Parent -> a - observer x _ = x - - constrain :: a -> a -> a - default constrain :: (Generic a) => a -> a -> a - constrain x _ = x - -observeBase :: a -> Parent -> a -observeBase x _ = x - -constrainBase :: a -> a -> a -constrainBase x _ = x - -newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) } - -instance Functor ObserverM where - fmap = liftM - -#if __GLASGOW_HASKELL__ >= 710 -instance Applicative ObserverM where - pure = return - (<*>) = ap -#endif - -instance Monad ObserverM where - return a = ObserverM (\ c i -> (a,i)) - fn >>= k = ObserverM (\ c i -> - case runMO fn c i of - (r,i2) -> runMO (k r) c i2 - ) - -(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b -fn << a = do {fn' <- fn; return (fn' a)} - -send :: String -> ObserverM a -> Parent -> a -send _ fn context = - unsafePerformIO $ do { let (r,portCount) = runMO fn 0 0 - ; return r - } - -instance Observable Int where - observer = observeBase - constrain = constrainBase - -instance Observable Bool where - observer = observeBase - constrain = constrainBase - -instance Observable Integer where - observer = observeBase - constrain = constrainBase - -instance Observable Float where - observer = observeBase - constrain = constrainBase - -instance Observable Double where - observer = observeBase - constrain = constrainBase - -instance Observable Char where - observer = observeBase - constrain = constrainBase - -instance Observable () where - observer = observeBase - constrain = constrainBase - -instance (Observable a) => Observable [a] where - observer = observeBase - constrain = constrainBase diff --git a/Debug/Hoed/Observe.lhs b/Debug/Hoed/Observe.lhs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Observe.lhs @@ -0,0 +1,742 @@ +\begin{code} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE CPP #-} + +\end{code} + +The file is part of the Haskell Object Observation Debugger, +(HOOD) March 2010 release. + +HOOD is a small post-mortem debugger for the lazy functional +language Haskell. It is based on the concept of observation of +intermediate data structures, rather than the more traditional +stepping and variable examination paradigm used by imperative +language debuggers. + +Copyright (c) Andy Gill, 1992-2000 +Copyright (c) The University of Kansas 2010 +Copyright (c) Maarten Faddegon, 2013-2015 + +All rights reserved. HOOD is distributed as free software under +the license in the file "License", which available from the HOOD +web page, http://www.haskell.org/hood + +This module produces CDS's, based on the observation made on Haskell +objects, including base types, constructors and functions. + +WARNING: unrestricted use of unsafePerformIO below. + +This was ported for the version found on www.haskell.org/hood. + + +%************************************************************************ +%* * +\subsection{Exports} +%* * +%************************************************************************ + +\begin{code} +module Debug.Hoed.Observe +{- + ( + -- * The main Hood API + + , observe + , Observer(..) -- contains a 'forall' typed observe (if supported). + , Observable(..) -- Class + + -- * For advanced users, that want to render their own datatypes. + , (<<) -- (Observable a) => ObserverM (a -> b) -> a -> ObserverM b + , thunk -- (Observable a) => a -> ObserverM a + , nothunk + , send + , observeBase + , observeOpaque + , observedTypes + , Generic + , Trace + , Event(..) + , Change(..) + , Parent(..) + , UID + , ParentPosition + , ThreadId(..) + , isRootEvent + , initUniq + , startEventStream + , endEventStream + , ourCatchAllIO + , peepUniq + ) -} where +\end{code} + + +%************************************************************************ +%* * +\subsection{Imports and infixing} +%* * +%************************************************************************ + +\begin{code} +import Prelude hiding (Right) +import qualified Prelude +import System.IO +import Data.Maybe +import Control.Monad +import Data.Array as Array +import Data.List +import Data.Char +import System.Environment + +import GHC.Generics + +import Data.IORef +import System.IO.Unsafe + +import Control.Concurrent(takeMVar,putMVar,MVar,newMVar) +import qualified Control.Concurrent as Concurrent +\end{code} + +For the TracedMonad instance of IO: +\begin{code} +import GHC.Base hiding (mapM, Type) +\end{code} + +\begin{code} +import qualified Control.Exception as Exception +import Control.Exception (Exception, throw, ErrorCall(..), SomeException(..)) +{- + ( catch + , Exception(..) + , throw + ) as Exception +-} +import Data.Dynamic ( Dynamic ) + +\end{code} + +\begin{code} +infixl 9 << +\end{code} + + +%************************************************************************ +%* * +\subsection{GDM Generics} +%* * +%************************************************************************ + +The generic implementation of the observer function. + +\begin{code} +class Observable a where + observer :: a -> Parent -> a + default observer :: (Generic a, GObservable (Rep a)) => a -> Parent -> a + observer x c = to (gdmobserver (from x) c) + + constrain :: a -> a -> a + default constrain :: (Generic a, GConstrain (Rep a)) => a -> a -> a + constrain x c = to (gconstrain (from x) (from c)) + +class GObservable f where + gdmobserver :: f a -> Parent -> f a + gdmObserveArgs :: f a -> ObserverM (f a) + gdmShallowShow :: f a -> String + +constrainBase :: (Show a, Eq a) => a -> a -> a +constrainBase x c | x == c = x + | otherwise = error $ show x ++ " constrained by " ++ show c +\end{code} + + +\begin{code} +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} Observable a where + observer = observeOpaque "" + constrain _ _ = error "contrained by untraced value" +#endif +\end{code} + +A type generic definition of constrain + +\begin{code} +class GConstrain f where gconstrain :: f a -> f a -> f a +instance (GConstrain a, GConstrain b) => GConstrain (a :+: b) where + gconstrain (L1 x) (L1 c) = L1 (gconstrain x c) + gconstrain (R1 x) (R1 c) = R1 (gconstrain x c) +instance (GConstrain a, GConstrain b) => GConstrain (a :*: b) where + gconstrain (x :*: y) (c :*: d) = (gconstrain x c) :*: (gconstrain y d) +instance GConstrain U1 where + gconstrain x c = x +instance (Observable a) => GConstrain (K1 i a) where + gconstrain (K1 x) (K1 c) = K1 (constrain x c) +instance (GConstrain a) => GConstrain (M1 D d a) where + gconstrain (M1 x) (M1 c) = M1 (gconstrain x c) +instance (GConstrain a, Selector s) => GConstrain (M1 S s a) where + gconstrain m@(M1 x) n@(M1 c) | selName m == selName n = M1 (gconstrain x c) +instance (GConstrain a, Constructor c) => GConstrain (M1 C c a) where + gconstrain m@(M1 x) n@(M1 c) | conName m == conName n = M1 (gconstrain x c) +\end{code} + +Observing the children of Data types of kind *. + +\begin{code} + +-- Meta: data types +instance (GObservable a) => GObservable (M1 D d a) where + gdmobserver m@(M1 x) cxt = M1 (gdmobserver x cxt) + gdmObserveArgs = gthunk + gdmShallowShow = error "gdmShallowShow not defined on the <>" + +-- Meta: Selectors +instance (GObservable a, Selector s) => GObservable (M1 S s a) where + gdmobserver (M1 x) cxt = M1 (gdmobserver x cxt) + gdmObserveArgs = gthunk + gdmShallowShow = error "gdmShallowShow not defined on the <>" + +-- Meta: Constructors +instance (GObservable a, Constructor c) => GObservable (M1 C c a) where + gdmobserver m1 = send (gdmShallowShow m1) (gdmObserveArgs m1) + gdmObserveArgs (M1 x) = do {x' <- gdmObserveArgs x; return (M1 x')} + gdmShallowShow = conName + +-- Unit: used for constructors without arguments +instance GObservable U1 where + gdmobserver x _ = x + gdmObserveArgs = return + gdmShallowShow = error "gdmShallowShow not defined on <>" + +-- Sums: encode choice between constructors +instance (GObservable a, GObservable b) => GObservable (a :+: b) where + gdmobserver (L1 x) = send (gdmShallowShow x) (gdmObserveArgs $ L1 x) + gdmobserver (R1 x) = send (gdmShallowShow x) (gdmObserveArgs $ R1 x) + gdmShallowShow (L1 x) = gdmShallowShow x + gdmShallowShow (R1 x) = gdmShallowShow x + gdmObserveArgs (L1 x) = do {x' <- gdmObserveArgs x; return (L1 x')} + gdmObserveArgs (R1 x) = do {x' <- gdmObserveArgs x; return (R1 x')} + +-- Products: encode multiple arguments to constructors +instance (GObservable a, GObservable b) => GObservable (a :*: b) where + gdmobserver (a :*: b) cxt = (gdmobserver a cxt) :*: (gdmobserver b cxt) + gdmObserveArgs (a :*: b) = do + a' <- gdmObserveArgs a + b' <- gdmObserveArgs b + return (a' :*: b') + gdmShallowShow = error "gdmShallowShow not defined on <>" + +-- Constants: additional parameters and recursion of kind * +instance (Observable a) => GObservable (K1 i a) where + gdmobserver (K1 x) cxt = K1 $ observer x cxt + gdmObserveArgs = gthunk + gdmShallowShow = error "gdmShallowShow not defined on <>" + +\end{code} + +Observing functions is done via the ad-hoc mechanism, because +we provide an instance definition the default is ignored for +this type. + +\begin{code} +instance (Observable a,Observable b) => Observable (a -> b) where + observer fn cxt arg = gdmFunObserver cxt fn arg + constrain = error "how to constrain the function type?" +\end{code} + +Observing the children of Data types of kind *->*. + +\begin{code} +gdmFunObserver :: (Observable a,Observable b) => Parent -> (a->b) -> (a->b) +gdmFunObserver cxt fn arg + = sendObserveFnPacket + (do arg' <- thunk observer arg + thunk observer (fn arg') + ) cxt +\end{code} + +%************************************************************************ +%* * +\subsection{Instances} +%* * +%************************************************************************ + + The Haskell Base types + +\begin{code} +instance Observable Int where observer = observeBase + constrain = constrainBase +instance Observable Bool where observer = observeBase + constrain = constrainBase +instance Observable Integer where observer = observeBase + constrain = constrainBase +instance Observable Float where observer = observeBase + constrain = constrainBase +instance Observable Double where observer = observeBase + constrain = constrainBase +instance Observable Char where observer = observeBase + constrain = constrainBase +instance Observable () where observer = observeOpaque "()" + constrain = constrainBase + +-- utilities for base types. +-- The strictness (by using seq) is the same +-- as the pattern matching done on other constructors. +-- we evalute to WHNF, and not further. + +observeBase :: (Show a) => a -> Parent -> a +observeBase lit cxt = seq lit $ send (show lit) (return lit) cxt + +observeOpaque :: String -> a -> Parent -> a +observeOpaque str val cxt = seq val $ send str (return val) cxt +\end{code} + +The Constructors. + +\begin{code} +instance (Observable a,Observable b) => Observable (a,b) where + observer (a,b) = send "," (return (,) << a << b) + +instance (Observable a,Observable b,Observable c) => Observable (a,b,c) where + observer (a,b,c) = send "," (return (,,) << a << b << c) + +instance (Observable a,Observable b,Observable c,Observable d) + => Observable (a,b,c,d) where + observer (a,b,c,d) = send "," (return (,,,) << a << b << c << d) + +instance (Observable a,Observable b,Observable c,Observable d,Observable e) + => Observable (a,b,c,d,e) where + observer (a,b,c,d,e) = send "," (return (,,,,) << a << b << c << d << e) + +instance (Observable a) => Observable [a] where + observer (a:as) = send ":" (return (:) << a << as) + observer [] = send "[]" (return []) + +instance (Observable a) => Observable (Maybe a) where + observer (Just a) = send "Just" (return Just << a) + observer Nothing = send "Nothing" (return Nothing) + +instance (Observable a,Observable b) => Observable (Either a b) where + observer (Left a) = send "Left" (return Left << a) + observer (Prelude.Right a) = send "Right" (return Prelude.Right << a) +\end{code} + +Arrays. + +\begin{code} +instance (Ix a,Observable a,Observable b) => Observable (Array.Array a b) where + observer arr = send "array" (return Array.array << Array.bounds arr + << Array.assocs arr + ) + constrain = undefined +\end{code} + +IO monad. + +\begin{code} +instance (Observable a) => Observable (IO a) where + observer fn cxt = + do res <- fn + send "" (return return << res) cxt + constrain = undefined +\end{code} + + + +The Exception *datatype* (not exceptions themselves!). + +\begin{code} +instance Observable SomeException where + observer e = send (" " ++ show e) (return e) + constrain = undefined + +-- instance Observable ErrorCall where +-- observer (ErrorCall a) = send "ErrorCall" (return ErrorCall << a) + + +instance Observable Dynamic where + observer = observeOpaque "" + constrain = undefined +\end{code} + + +%************************************************************************ +%* * +\subsection{Classes and Data Definitions} +%* * +%************************************************************************ + +MF: why/when do we need these types? +\begin{code} +type Observing a = a -> a + +newtype Observer = O (forall a . (Observable a) => String -> a -> a) +\end{code} + + +%************************************************************************ +%* * +\subsection{The ObserveM Monad} +%* * +%************************************************************************ + +The Observer monad, a simple state monad, +for placing numbers on sub-observations. + +\begin{code} +newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) } + +instance Functor ObserverM where + fmap = liftM + +#if __GLASGOW_HASKELL__ >= 710 +instance Applicative ObserverM where + pure = return + (<*>) = ap +#endif + +instance Monad ObserverM where + return a = ObserverM (\ c i -> (a,i)) + fn >>= k = ObserverM (\ c i -> + case runMO fn c i of + (r,i2) -> runMO (k r) c i2 + ) + +thunk :: (a -> Parent -> a) -> a -> ObserverM a +thunk f a = ObserverM $ \ parent port -> + ( observer_ f a (Parent + { parentUID = parent + , parentPosition = port + }) + , port+1 ) + +gthunk :: (GObservable f) => f a -> ObserverM (f a) +gthunk a = ObserverM $ \ parent port -> + ( gdmobserver_ a (Parent + { parentUID = parent + , parentPosition = port + }) + , port+1 ) + +nothunk :: a -> ObserverM a +nothunk a = ObserverM $ \ parent port -> + ( observer__ a (Parent + { parentUID = parent + , parentPosition = port + }) + , port+1 ) + + +(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b +-- fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') } +fn << a = gdMapM (thunk observer) fn a + +gdMapM :: (Monad m) + => (a -> m a) -- f + -> m (a -> b) -- data constructor + -> a -- argument + -> m b -- data +gdMapM f c a = do { c' <- c ; a' <- f a ; return (c' a') } + +\end{code} + + +%************************************************************************ +%* * +\subsection{observe and friends} +%* * +%************************************************************************ + +Our principle function and class + +\begin{code} +-- | 'observe' observes data structures in flight. +-- +-- An example of use is +-- @ +-- map (+1) . observe \"intermeduate\" . map (+2) +-- @ +-- +-- In this example, we observe the value that flows from the producer +-- @map (+2)@ to the consumer @map (+1)@. +-- +-- 'observe' can also observe functions as well a structural values. +-- +{-# NOINLINE gobserve #-} +gobserve :: (a->Parent->a) -> String -> a -> (a,Int) +gobserve f name a = generateContext f name a + +{- | +Functions which you suspect of misbehaving are annotated with observe and +should have a cost centre set. The name of the function, the label of the cost +centre and the label given to observe need to be the same. + +Consider the following function: + +@triple x = x + x@ + +This function is annotated as follows: + +> triple y = (observe "triple" (\x -> {# SCC "triple" #} x + x)) y + +To produce computation statements like: + +@triple 3 = 6@ + +To observe a value its type needs to be of class Observable. +We provided instances for many types already. +If you have defined your own type, and want to observe a function +that takes a value of this type as argument or returns a value of this type, +an Observable instance can be derived as follows: + +@ + data MyType = MyNumber Int | MyName String deriving Generic + + instance Observable MyType +@ +-} +{-# NOINLINE observe #-} +observe :: (Observable a) => String -> a -> a +observe lbl = fst . (gobserve observer lbl) + +{- This gets called before observer, allowing us to mark + - we are entering a, before we do case analysis on + - our object. + -} + +{-# NOINLINE observer_ #-} +observer_ :: (a -> Parent -> a) -> a -> Parent -> a +observer_ f a context = sendEnterPacket f a context + +gdmobserver_ :: (GObservable f) => f a -> Parent -> f a +gdmobserver_ a context = gsendEnterPacket a context + +{-# NOINLINE observer__ #-} +observer__ :: a -> Parent -> a +observer__ a context = sendNoEnterPacket a context + +\end{code} + +The functions that output the data. All are dirty. + +\begin{code} +unsafeWithUniq :: (Int -> IO a) -> a +unsafeWithUniq fn + = unsafePerformIO $ do { node <- getUniq + ; fn node + } +\end{code} + +\begin{code} +generateContext :: (a->Parent->a) -> String -> a -> (a,Int) +generateContext f {- tti -} label orig = unsafeWithUniq $ \node -> + do sendEvent node (Parent 0 0) (Observe label node) + return (observer_ f orig (Parent + { parentUID = node + , parentPosition = 0 + }) + , node) + +send :: String -> ObserverM a -> Parent -> a +send consLabel fn context = unsafeWithUniq $ \ node -> + do { let (r,portCount) = runMO fn node 0 + ; sendEvent node context (Cons portCount consLabel) + ; return r + } + +sendEnterPacket :: (a -> Parent -> a) -> a -> Parent -> a +sendEnterPacket f r context = unsafeWithUniq $ \ node -> + do { sendEvent node context Enter + ; ourCatchAllIO (evaluate (f r context)) + (handleExc context) + } + +gsendEnterPacket :: (GObservable f) => f a -> Parent -> f a +gsendEnterPacket r context = unsafeWithUniq $ \ node -> + do { sendEvent node context Enter + ; ourCatchAllIO (evaluate (gdmobserver r context)) + (handleExc context) + } + +sendNoEnterPacket :: a -> Parent -> a +sendNoEnterPacket r context = unsafeWithUniq $ \ node -> + do { sendEvent node context NoEnter + ; ourCatchAllIO (evaluate r) + (handleExc context) + } + +evaluate :: a -> IO a +evaluate a = a `seq` return a + +sendObserveFnPacket :: ObserverM a -> Parent -> a +sendObserveFnPacket fn context + = unsafeWithUniq $ \ node -> + do { let (r,_) = runMO fn node 0 + ; sendEvent node context Fun + ; return r + } +\end{code} + + +%************************************************************************ +%* * +\subsection{Event stream} +%* * +%************************************************************************ + +Trival output functions + +\begin{code} +type Trace = [Event] + +data Event = Event + { eventUID :: !UID -- my UID + , eventParent :: !Parent + , change :: !Change + } + deriving (Eq,Generic) + +data Change + = Observe !String !Int + | Cons !Int !String + | Enter + | NoEnter + | Fun + deriving (Eq, Show,Generic) + +type ParentPosition = Int + +data Parent = Parent + { parentUID :: !UID -- my parents UID + , parentPosition :: !ParentPosition -- my branch number (e.g. the field of a data constructor) + } deriving (Eq,Generic) + +instance Show Event where + show e = (show . eventUID $ e) ++ ": " ++ (show . change $ e) ++ " (" ++ (show . eventParent $ e) ++ ")" + +instance Show Parent where + show p = "P " ++ (show . parentUID $ p) ++ " " ++ (show . parentPosition $ p) + +root = Parent 0 0 + +isRootEvent :: Event -> Bool +isRootEvent e = case change e of Observe{} -> True; _ -> False + +startEventStream :: IO () +startEventStream = writeIORef events [] + +endEventStream :: IO Trace +endEventStream = + do { es <- readIORef events + ; writeIORef events badEvents + ; return es + } + +sendEvent :: Int -> Parent -> Change -> IO () +sendEvent nodeId parent change = + do { nodeId `seq` parent `seq` return () + ; change `seq` return () + ; takeMVar sendSem + ; es <- readIORef events + ; let event = Event nodeId parent change + ; writeIORef events (event `seq` (event : es)) + ; putMVar sendSem () + } + +-- local +events :: IORef Trace +events = unsafePerformIO $ newIORef badEvents + +badEvents :: Trace +badEvents = error "Bad Event Stream" + +-- use as a trivial semiphore +{-# NOINLINE sendSem #-} +sendSem :: MVar () +sendSem = unsafePerformIO $ newMVar () +-- end local +\end{code} + + +%************************************************************************ +%* * +\subsection{unique name supply code} +%* * +%************************************************************************ + +Use the single threaded version + +\begin{code} +type UID = Int + +initUniq :: IO () +initUniq = writeIORef uniq 1 + +getUniq :: IO UID +getUniq + = do { takeMVar uniqSem + ; n <- readIORef uniq + ; writeIORef uniq $! (n + 1) + ; putMVar uniqSem () + ; return n + } + +peepUniq :: IO UID +peepUniq = readIORef uniq + +-- locals +{-# NOINLINE uniq #-} +uniq :: IORef UID +uniq = unsafePerformIO $ newIORef 1 + +{-# NOINLINE uniqSem #-} +uniqSem :: MVar () +uniqSem = unsafePerformIO $ newMVar () +\end{code} + + + +%************************************************************************ +%* * +\subsection{Global, initualizers, etc} +%* * +%************************************************************************ + +-- \begin{code} +-- openObserveGlobal :: IO () +-- openObserveGlobal = +-- do { initUniq +-- ; startEventStream +-- } +-- +-- closeObserveGlobal :: IO Trace +-- closeObserveGlobal = +-- do { evs <- endEventStream +-- ; putStrLn "" +-- ; return evs +-- } +-- \end{code} + +%************************************************************************ +%* * +\subsection{Simulations} +%* * +%************************************************************************ + +Here we provide stubs for the functionally that is not supported +by some compilers, and provide some combinators of various flavors. + +\begin{code} +ourCatchAllIO :: IO a -> (SomeException -> IO a) -> IO a +ourCatchAllIO = Exception.catch + +handleExc :: Parent -> SomeException -> IO a +-- handleExc context exc = return (send "throw" (return throw << exc) context) +handleExc context exc = return (send (show exc) (return (throw exc)) context) +\end{code} + +%************************************************************************ diff --git a/Debug/Hoed/Prop.hs b/Debug/Hoed/Prop.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Prop.hs @@ -0,0 +1,694 @@ +-- This file is part of the Haskell debugger Hoed. +-- +-- Copyright (c) Maarten Faddegon 2015-2016 + +{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances, StandaloneDeriving, CPP, DeriveGeneric #-} + +module Debug.Hoed.Prop where +-- ( judge +-- , Propositions(..) +-- ) where +import Debug.Hoed.Observe(Observable(..),Trace(..),UID,Event(..),Change(..),ourCatchAllIO,evaluate,eventParent,parentPosition) +import Debug.Hoed.Render(CompStmt(..),noNewlines) +import Debug.Hoed.CompTree(CompTree,Vertex(..),Graph(..),vertexUID,vertexRes,replaceVertex,getJudgement,setJudgement) +import Debug.Hoed.EventForest(EventForest,mkEventForest,dfsChildren) +import Debug.Hoed.Serialize +import qualified Data.IntMap as M +import Prelude hiding (Right) +import Data.Graph.Libgraph(Judgement(..),AssistedMessage(..),mapGraph) +import System.Directory(createDirectoryIfMissing) +import System.Process(system) +import System.Exit(ExitCode(..)) +import System.IO(hPutStrLn,stderr) +import System.IO.Unsafe(unsafePerformIO) +import Data.Char(isAlpha) +import Data.Maybe(isNothing,fromJust,isJust) +import Data.List(intersperse,isInfixOf,foldl1) +import GHC.Generics hiding (moduleName) --(Generic(..),Rep(..),from,(:+:)(..),(:*:)(..),U1(..),K1(..),M1(..)) +import Control.Monad(foldM) + +------------------------------------------------------------------------------------------------------------------------ + +data Propositions = Propositions { propositions :: [Proposition] + , propType :: PropType + , funName :: String + , extraModules :: [Module] + } + +data PropType = Specify | PropertiesOf deriving Eq + +data Signature + = Argument Int + | SubjectFunction + | Random + deriving (Show,Eq) + +data TestGen = TestGenQuickCheck | TestGenLegacyQuickCheck -- TestGenSmallCheck + deriving Show + +data Proposition = Proposition { propositionType :: PropositionType + , propModule :: Module + , propName :: String + , signature :: [Signature] + , maxSize :: Maybe Int + , testgen :: TestGen + } deriving Show + +mkProposition :: Module -> String -> Proposition +mkProposition m f = Proposition { propositionType = BoolProposition + , propModule = m + , propName = f + , signature = [SubjectFunction,Argument 0] + , maxSize = Nothing + , testgen = TestGenQuickCheck + } + +ofType :: Proposition -> PropositionType -> Proposition +ofType p t = p{propositionType = t} + +withSignature :: Proposition -> [Signature] -> Proposition +withSignature p s = p{signature = s} + +sizeHint :: Proposition -> Int -> Proposition +sizeHint p n = p{maxSize = Just n} + +withTestGen :: Proposition -> TestGen -> Proposition +withTestGen p f = p{testgen=f} + +data PropositionType + = IOProposition + | BoolProposition + | LegacyQuickCheckProposition + | QuickCheckProposition + deriving Show + +data Module = Module {moduleName :: String, searchPath :: String} + deriving Show + +data PropRes + = Error Proposition String + | Hold Proposition + | HoldWeak Proposition + | Disprove Proposition + | DisproveBy Proposition [String] + deriving Show + +------------------------------------------------------------------------------------------------------------------------ + +sourceFile = ".Hoed/exe/Main.hs" +buildFiles = ".Hoed/exe/Main.o .Hoed/exe/Main.hi" +exeFile = ".Hoed/exe/Main" +outFile = ".Hoed/exe/Main.out" +errFile = ".Hoed/exe/Main.compilerMessages" +treeFilePath = ".Hoed/savedCompTree." +traceFilePath = ".Hoed/savedTrace." + +------------------------------------------------------------------------------------------------------------------------ + +lookupPropositions :: [Propositions] -> Vertex -> Maybe Propositions +lookupPropositions _ RootVertex = Nothing +lookupPropositions ps v = lookupWith funName lbl ps + where lbl = (stmtLabel . vertexStmt) v + +lookupWith :: Eq a => (b->a) -> a -> [b] -> Maybe b +lookupWith f x ys = case filter (\y -> f y == x) ys of + [] -> Nothing + (y:_) -> Just y + +------------------------------------------------------------------------------------------------------------------------ + + +data Judge + = Judge Judgement + -- ^ Returns a Judgement (see Libgraph library). + | AlternativeTree CompTree Trace + -- ^ Found counter example with simpler computation tree. + +-- TODO: review this function, not sure if complexity suggestion actually makes sense there... +judgeAll :: UnevalHandler -> (CompTree -> Int) -> Trace -> [Propositions] -> CompTree -> IO CompTree +judgeAll handler complexity trc ps compTree = foldM f compTree (vertices compTree) + where + c = complexity compTree + f :: CompTree -> Vertex -> IO CompTree + f curTree v = do + putStrLn $ take 50 (cycle "-") + putStrLn $ "Evaluating properties to judge statement: " ++ vertexRes v + putStrLn $ take 50 (cycle "-") + case lookupPropositions ps v of + Nothing -> do + putStrLn "*** no propositions" + return curTree + (Just p) -> do + j <- judge' handler trc p v complexity curTree + case j of + (Judge jmt) -> do + putStrLn $ "*** judgement is " ++ show jmt + return $ replaceVertex curTree (setJudgement v jmt) + (AlternativeTree t' _) -> do + let msg = "Simpler tree suggested with complexity " ++ show (complexity t') + ++ "(current tree has complexity of " ++ show c ++ ")" + putStrLn $ "*** " ++ msg + return $ replaceVertex curTree (setJudgement v (Assisted [InconclusiveProperty msg])) + + +-- |Use propositions to judge a computation statement. +-- First tries restricted and bottom for unevaluated expressions, +-- then unrestricted, and finally with randomly generated values +-- for unevaluated expressions. +judge :: Trace -> Propositions -> Vertex -> (CompTree -> Int) -> CompTree -> IO Judge +judge trc p v complexity curTree = do + putStrLn $ take 50 (cycle "-") + putStrLn $ "Evaluating properties to judge statement: " ++ vertexRes v + putStrLn $ take 50 (cycle "-") + putStrLn "### ATTEMPT 1: with a restricted subject function\n" + res1 <- judge' RestrictedBottom trc p v complexity curTree + case res1 of + (Judge (Assisted _)) -> do + putStrLn "### ATTEMPT 2: with an unrestricted subject function\n" + res2 <- judge' Bottom trc p v complexity curTree + case res2 of + (Judge (Assisted _)) -> do + putStrLn "### ATTEMPT 3: with randomly generated values\n" + judge' Forall trc p v complexity curTree + _ -> return res2 + (Judge _) -> return res1 + return res1 + +judge' RestrictedBottom trc p v complexity curTree = do + pas <- evalPropositions RestrictedBottom trc p v + let j | propType p == Specify && all holds pas = (Judge Right) + | any disproves pas = (Judge Wrong) + | otherwise = advice pas + return j + +judge' handler trc p v complexity curTree = do + pas <- evalPropositions handler trc p v + let j | propType p == Specify && all holds pas = return (Judge Right) + | any disproves pas = do + let curComplexity = complexity curTree + (bestComplexity,bestTree,bestTrace) <- simplestTree complexity (extraModules p) pas (curComplexity,curTree,[]) trc v + if bestComplexity == curComplexity + then return $ Judge $ Assisted $ [InconclusiveProperty $ "We found values for the unevaluated " + ++ "expressions in the current statement that falsify\n" + ++ "a property, however the resulting tree is not simpler."] + else return (AlternativeTree bestTree bestTrace) + | otherwise = return (advice pas) + j + +holds :: PropRes -> Bool +holds (Hold _) = True +holds (HoldWeak _) = True +holds _ = False + +disproves :: PropRes -> Bool +disproves (Disprove _) = True +disproves (DisproveBy _ _) = True +disproves _ = False + +disprovesBy :: PropRes -> Bool +disprovesBy (DisproveBy _ _) = True +disprovesBy _ = False + +-- Using the given complexity function, compare the computation trees of the list of +-- property results and select the simplest tree. +simplestTree :: (CompTree -> Int) -> [Module] -> [PropRes] -> (Int,CompTree,Trace) -> Trace -> Vertex -> IO (Int,CompTree,Trace) +simplestTree complexity ms rs cur trc v = foldM (simple2 complexity trc v ms) cur (filter disproves rs) + +-- Using the given complexity function, read the computation tree of the given property +-- into memory and compare its complexity with the complexity of the currently best tree. +-- Return whichever of these two trees is simplest. +simple2 :: (CompTree -> Int) -> Trace -> Vertex -> [Module] -> (Int,CompTree,Trace) -> PropRes -> IO (Int,CompTree,Trace) +simple2 complexity trc v ms (curComplexity,curTree,curTrace) propRes = do + reEvalProposition propRes trc v ms + maybeCandTree <- restoreTree $ treeFilePath ++ resOf propRes + maybeCandTrace <- restoreTrace $ traceFilePath ++ resOf propRes + case (maybeCandTree,maybeCandTrace) of + (Just candTree, Just candTrace) -> do + let candComplexity = complexity candTree + putStrLn $ "Discovered new tree with complexity " ++ show candComplexity + ++ " (current tree is " ++ show curComplexity ++ ")" + return $ if candComplexity < curComplexity + then (candComplexity,candTree,candTrace) + else (curComplexity,curTree,curTrace) + _ -> do + putStrLn $ "FAILED to to restore computation tree of " ++ resOf propRes + return (curComplexity,curTree,curTrace) + +advice :: [PropRes] -> Judge +advice rs' = case filter holds rs' of + [] -> Judge $ Assisted $ errorMessages rs' + rs -> Judge $ Assisted $ PassingProperty (commas (map resOf rs)) : errorMessages rs' + +commas :: [String] -> String +commas = concat . (intersperse ", ") + +errorMessages :: [PropRes] -> [AssistedMessage] +errorMessages = foldl (\acc (Error prop msg) -> InconclusiveProperty ("\n---\n\nApplying property " ++ propName prop ++ " gives inconclusive result:\n\n" ++ msg) : acc) [] . filter isError + +isError (Error _ _) = True +isError _ = False + +data UnevalHandler = RestrictedBottom | Bottom | Forall | FromList [String] deriving (Eq, Show) + +unevalHandler :: UnevalHandler -> PropVarGen String +unevalHandler RestrictedBottom = propVarError +unevalHandler Bottom = propVarError +unevalHandler Forall = propVarFresh +unevalHandler (FromList _) = propVarFresh + +unevalState :: UnevalHandler -> PropVars +unevalState RestrictedBottom = propVars0 +unevalState Bottom = propVars0 +unevalState Forall = propVars0 +-- unevalState (FromList _) = propVars0 +-- Replace last line with +unevalState (FromList values) = ([],values) +-- to directly substitute unevaluated expressions with the FromList values. +-- This is only valid when all randomly generated values are actually substituting +-- unevaluated expressions (this is not always the case, consider e.g. testing f in +-- quickCheck p where p f x y = f x == g x y) + +resOf :: PropRes -> String +resOf (Error p _) = propName p +resOf (Hold p) = propName p +resOf (HoldWeak p) = propName p +resOf (Disprove p) = propName p +resOf (DisproveBy p _) = propName p + +evalPropositions :: UnevalHandler -> Trace -> Propositions -> Vertex -> IO [PropRes] +evalPropositions _ _ _ RootVertex = return [] +evalPropositions handler trc p v = mapM (evalProposition handler trc v (extraModules p)) (propositions p) + +evalProposition :: UnevalHandler -> Trace -> Vertex -> [Module] -> Proposition -> IO PropRes +evalProposition RestrictedBottom trc v ms prop | not (SubjectFunction `elem` (signature prop)) = do + putStrLn $ "property " ++ propName prop ++ ": Cannot restrict subject function!" + return $ Error prop "Cannot restrict subject function!" +evalProposition handler trc v ms prop = do + putStrLn $ "property " ++ propName prop + createDirectoryIfMissing True ".Hoed/exe" + clean + prgm <- generateCode handler trc v prop ms + compile prop + exit <- compile prop + case exit of + (ExitFailure _) -> do + err <- readFile errFile + putStrLn $ "failed to compile: " ++ err + return $ Error prop $ "Compilation of {{{\n" ++ prgm ++ "\n}}} failed with:\n" ++ err + ExitSuccess -> do + exit <- run + out <- readFile outFile + putStrLn $ "evaluated to: " ++ out + return $ mkPropRes prop exit (backspaces out) + + +reEvalProposition :: PropRes -> Trace -> Vertex -> [Module] -> IO PropRes +reEvalProposition (Disprove prop) _ _ _ = return (Disprove prop) -- no need to re-evaluate +reEvalProposition (DisproveBy prop values) trc v ms = do + putStrLn $ "RE-EVALUATE with " ++ concat valuesInBrackets ++ " {" + (Disprove p) <- evalProposition (FromList valuesInBrackets) trc v ms prop + putStrLn $ "} RE-EVALUATE" + return (Disprove p) + where + valuesInBrackets = map (\s -> " (" ++ s ++ ") ") values + +clean = system $ "rm -f " ++ sourceFile ++ " " ++ exeFile ++ " " ++ buildFiles + +compile prop = do + putStrLn cmd + system cmd + where cmd = "ghc -dynamic -i" ++ (searchPath . propModule) prop ++ " -o " ++ exeFile ++ " " ++ sourceFile ++ " > " ++ errFile ++ " 2>&1" + +run = system $ exeFile ++ " > " ++ outFile ++ " 2>&1" + +generateCode :: UnevalHandler -> Trace -> Vertex -> Proposition -> [Module] -> IO String +generateCode handler trc v prop ms = do + -- Uncomment the next line to dump generated program on screen + -- hPutStrLn stderr $ "Generated the following program ***\n" ++ prgm ++ "\n***" + writeFile sourceFile prgm + return prgm + where + prgm = generate handler prop ms trc (getEventFromMap $ eventMap trc) i f + i = (stmtIdentifier . vertexStmt) v + f = (stmtLabel . vertexStmt) v + + +getEventFromMap m j = fromJust $ M.lookup j m + +eventMap trc = M.fromList $ map (\e -> (eventUID e, e)) trc + +mkPropRes :: Proposition -> ExitCode -> String -> PropRes +mkPropRes prop (ExitFailure _) out = Error prop out +mkPropRes prop ExitSuccess out + | out == "True\n" = Hold prop + | out == "+++ OK, passed 100 tests.\n" = HoldWeak prop + | out == "False\n" = Disprove prop + | "Falsifiable" `isInfixOf` out = DisproveBy prop (reverse . tail . lines $ out) + | otherwise = Error prop out + +shorten s + | length s < 120 = s + | otherwise = (take 117 s) ++ "..." + +backspaces :: String -> String +backspaces s = reverse (backspaces' [] s) + where + backspaces' s [] = s + backspaces' s (c:t) + | c == '\b' = backspaces' (safeTail s) t + | otherwise = backspaces' (c:s) t + + safeTail [] = [] + safeTail (c:s) = s + +------------------------------------------------------------------------------------------------------------------------ + +type PropVars = ([String],[String]) -- A tuple of used variables, and a supply of fresh variables +type PropVarGen a = PropVars -> (a,PropVars) + +comp :: PropVarGen a -> PropVarGen b -> (a -> b -> c) -> PropVarGen c +comp x y f vs = let (x', vs') = x vs + (y', vs'') = y vs' + in (f x' y', vs'') + +-- MF TODO: this is exactly like liftM2 +liftPV :: (a -> b -> c) -> PropVarGen a -> PropVarGen b -> PropVarGen c +liftPV f x y = comp x y f + +propVars0 :: PropVars +propVars0 = ([], map show [1..]) + +propVarError :: PropVarGen String +-- propVarError = propVarReturn "(error \"Request of value that was unevaluated in original program.\")" +propVarError (bvs,v:fvs) = (x, (bvs,fvs)) + where x = "(error \"Request of value that was unevaluated in original program (underscore " ++ v ++ " in computation statement).\")" + +propVarFresh :: PropVarGen String +propVarFresh (bvs,v:fvs) = (x, (x:bvs,fvs)) where x = 'x':v + +propVarReturn :: String -> PropVarGen String +propVarReturn s vs = (s,vs) + +propVarBind :: UnevalHandler -> (String,PropVars) -> Proposition -> String +propVarBind (FromList _) (propApp,_) prop = generatePrint prop ++ propApp +propVarBind _ (propApp,([],_)) prop = generatePrint prop ++ propApp +propVarBind _ (propApp,(bvs,_)) prop = qc ++ " (\\" ++ bvs' ++ " -> " ++ propApp ++ ")" + where + bvs' = concat (intersperse " " bvs) + qc = case (testgen prop, maxSize prop) of + (TestGenQuickCheck, Nothing) + -> "quickCheckWith stdArgs{maxDiscardRatio=50}" + (TestGenQuickCheck, Just n) + -> "quickCheckWith stdArgs{maxDiscardRatio=50,maxSize=" ++ show n ++ "}" + (TestGenLegacyQuickCheck, Nothing) + -> "check defaultConfig{configMaxFail=5000}" + (TestGenLegacyQuickCheck, Just n) + -> "check defaultConfig{configMaxFail=5000,configSize=(+" ++ show n ++ ") . (`div` 2)}" + +generatePrint :: Proposition -> String +generatePrint p = case propositionType p of + IOProposition -> "" + BoolProposition -> "print $ " + QuickCheckProposition -> "(\\q -> do MkRose res ts <- reduceRose . unProp . (\\p->unGen p (mkQCGen 1) 1) . unProperty $ q; print . fromJust . ok $ res) $ " + LegacyQuickCheckProposition -> "do g <- newStdGen; print . fromJust . ok . (generate 1 g) . evaluate $ " + +------------------------------------------------------------------------------------------------------------------------ + +generate :: UnevalHandler -> Proposition -> [Module ] -> Trace -> (UID->Event) -> UID -> String -> String +generate handler prop ms trc getEvent i f = generateHeading prop ms ++ generateMain handler prop trc getEvent i f + +generateHeading :: Proposition -> [Module] -> String +generateHeading prop ms = + "-- This file is generated by the Haskell debugger Hoed\n" + ++ generateImport (propModule prop) + ++ generateImport (Module "qualified Debug.Hoed as Hoed" []) + ++ qcImports + ++ foldl (\acc m -> acc ++ generateImport m) "" ms + where + qcImports = case propositionType prop of + BoolProposition -> generateImport (Module "Test.QuickCheck" []) + IOProposition -> generateImport (Module "Test.QuickCheck" []) + LegacyQuickCheckProposition -> qcImports' + QuickCheckProposition -> qcImports' + ++ generateImport (Module "Test.QuickCheck.Property" []) + ++ generateImport (Module "Test.QuickCheck.Gen" []) + ++ generateImport (Module "Test.QuickCheck.Random" []) + qcImports' + = generateImport (Module "System.Random" []) -- newStdGen + ++ generateImport (Module "Data.Maybe" []) -- fromJust + ++ generateImport (Module "Test.QuickCheck" []) + +generateImport :: Module -> String +generateImport m = "import " ++ (moduleName m) ++ "\n" + +generateMain :: UnevalHandler -> Proposition -> Trace -> (UID->Event) -> UID -> String -> String +generateMain handler prop trc getEvent i f + = "main = Hoed.runOstore \"" ++ (propName prop) ++"\" $ " + ++ propVarBind handler (foldl accSig ((propName prop) ++ " ",unevalState handler) (signature prop)) prop + -- ++ appValues handler + ++ "\n" + where + -- appValues (FromList values) = concat (map (" "++) values) + -- appValues _ = "" + accSig :: (String,PropVars) -> Signature -> (String,PropVars) + accSig (acc,propVars) x = let (s,propVars') = getSig x propVars in (acc ++ " " ++ s, propVars') + getSig :: Signature -> PropVarGen String + getSig SubjectFunction = cf + getSig (Argument i) | i < length args = args !! i + -- MF TODO: should we do something better when user gives index that is out of bounds? + getSig Random = propVarFresh + getSig _ = propVarError + + args :: [PropVarGen String] + args = generateArgs (unevalHandler handler) trc getEvent i + + cf :: PropVarGen String + cf | handler == RestrictedBottom + = foldl1 (liftPV $ \acc c -> acc ++ " " ++ c) + [ propVarReturn $ "(" ++ genConAp (length args) f + , generateRes (unevalHandler handler) trc getEvent i + , propVarReturn $ ")" + ] + | otherwise = propVarReturn f + +generateRes :: (PropVarGen String) -> Trace -> (UID -> Event) -> UID -> PropVarGen String +generateRes unevalGen trc getEvent i + | areFun mres = (propVarReturn " {- generateRes -} ") `pvCat` + (generateRes unevalGen trc getEvent (eventUID . head . justFuns $ mres)) -- (*) + | otherwise = case mres of [_,mr] -> generateRes' unevalGen trc getEvent mr + -- + -- (*) MF TODO: can there be multiple funs in mres? what then? + -- + where + mres = filter isJustRes children + mr = case mres of [_,e] -> e; _ -> Nothing + children = dfsChildren frt e + frt = (mkEventForest trc) + e = getEvent i + +generateRes' :: PropVarGen String -> Trace -> (UID->Event) -> Maybe Event -> PropVarGen String +generateRes' unevalGen trc getEvent Nothing = unevalGen +generateRes' unevalGen trc getEvent (Just e) + | change e == Fun = + case dfsChildren frt e of + [_,_ ,_,mr] -> + generateRes' unevalGen trc getEvent mr + [Nothing,_,mr] -> + generateRes' unevalGen trc getEvent mr + as -> + error $ "generateRes': event " ++ show (eventUID e) + ++ ":FUN has " ++ show (length as) ++ " children!\nnamely: " ++ commas (map show as) + | otherwise = generateExpr unevalGen trc getEvent frt (Just e) + where + frt = (mkEventForest trc) + +generateArgs :: (PropVarGen String) -> Trace -> (UID -> Event) -> UID -> [PropVarGen String] +generateArgs unevalGen trc getEvent i = + (propVarReturn " {- generateArgs -} ") `pvCat` + pvArg `pvCat` (propVarReturn $ " {- more: " ++ show mres ++ " -} ") + : moreArgs unevalGen trc getEvent mr + where + pvArg | areFun marg = generateFunMap unevalGen trc getEvent (justFuns marg) + | otherwise = case marg of + [Nothing] -> unevalGen + [_,ma] -> generateExpr unevalGen trc getEvent frt ma + e = getEvent i + marg = filter nothingOrArg children + mres = filter isJustRes children + mr = case mres of [_,e] -> e; _ -> Nothing + children = dfsChildren frt e + frt = (mkEventForest trc) + +nothingOrArg Nothing = True +nothingOrArg (Just e) = isArg e + +noArg [Nothing] = True +noArg _ = False + +areFun :: [Maybe Event] -> Bool +areFun (_:e:_) = isJustFun e +areFun _ = False + +justFuns :: [Maybe Event] -> [Event] +justFuns = map fromJust . filter isJustFun + +isJustFun :: Maybe Event -> Bool +isJustFun (Just e) = change e == Fun +isJustFun Nothing = False + +generateFunMap :: (PropVarGen String) -> Trace -> (UID -> Event) -> [Event] -> PropVarGen String +generateFunMap unevalGen trc getEvent funs + | length funs > 0 = caseOf `pvCat` (pvConcat cases') `pvCat` esac + | otherwise = propVarReturn "{- a fun without applications? -}" + where + caseOf = propVarReturn $ " {- funmap with " ++ (show . length $ funs ) ++ " cases -} " + ++ "(\\y -> case y of " + esac = propVarReturn ")" + cases, cases' :: [PropVarGen String] + cases = map (\fun -> generateCase unevalGen trc getEvent fun) funs + cases' = intersperse (propVarReturn "; ") cases + +generateCase :: (PropVarGen String) -> Trace -> (UID -> Event) -> Event -> PropVarGen String +generateCase unevalGen trc getEvent fun = + (propVarReturn $ " {- CASE " ++ show fun ++ " -} ") `pvCat` + case args of + [] -> (propVarReturn "{- catchall -} _") --> res + _ -> (foldl1 (liftPV $ \acc c -> acc ++ " " ++ c) args) --> res + where + args :: [PropVarGen String] + args = map (generateExpr (propVarReturn "_") trc getEvent frt) + . filter (\(Just e) -> isArg e) . filter isJust . dfsChildren frt $ fun + res :: PropVarGen String + res = generateRes unevalGen trc getEvent (eventUID fun) + (-->) :: PropVarGen String -> PropVarGen String -> PropVarGen String + (-->) = liftPV $ \x y -> x ++ " -> " ++ y + frt = mkEventForest trc -- MF TODO: create just once and share? + +isArg = hasParentPos 0 + +isRes = hasParentPos 1 + +isJustRes (Just e) = isRes e +isJustRes Nothing = False + +hasParentPos i = (==i) . parentPosition . eventParent + +pvCat :: PropVarGen String -> PropVarGen String -> PropVarGen String +pvCat = liftPV (++) + +pvConcat :: [PropVarGen String] -> PropVarGen String +pvConcat = foldl pvCat (propVarReturn "") + +moreArgs :: PropVarGen String -> Trace -> (UID->Event) -> Maybe Event -> [PropVarGen String] +moreArgs _ trc getEvent Nothing = [] +moreArgs unevalGen trc getEvent (Just e) + | change e == Fun = generateArgs unevalGen trc getEvent (eventUID e) + | otherwise = [] + +generateExpr :: PropVarGen String -> Trace -> (UID -> Event) -> EventForest -> Maybe Event -> PropVarGen String +generateExpr unevalGen _ _ _ Nothing = unevalGen +generateExpr unevalGen trc getEvent frt (Just e) = + -- (propVarReturn $ "{- generateExpr " ++ show e ++ "-}") `pvCat` + case change e of + (Cons _ s) -> let s' = if isAlpha (head s) then s else "(" ++ s ++ ")" + in liftPV (++) ( foldl (liftPV $ \acc c -> acc ++ " " ++ c) + (propVarReturn ("(" ++ s')) cs + ) + ( propVarReturn ") " + ) + Enter -> propVarReturn "" + -- Fun -> generateFunMap unevalGen trc getEvent (justFuns xs) + evnt -> propVarReturn $ "error \"cannot represent: " ++ show evnt ++ "\"" + + where cs :: [PropVarGen String] + cs = map (generateExpr unevalGen trc getEvent frt) xs + xs = (dfsChildren frt e) + + +-- only works if there is 1 argument +conAp :: Observable b => (a -> b) -> b -> a -> b +conAp f r x = constrain (f x) r + +genConAp :: Int -> String -> String +genConAp n f | n > 0 = "(\\r " ++ args ++ " -> Hoed.constrain (" ++ f ++ " " ++ args ++ ") r)" + where args = foldl1 (\a x -> a ++ " " ++ x) xs + xs = map (\i -> "x" ++ show i) [1..n] + +-------------------------------------------------------------------------------- +-- MF TODO: this should probably be part of the Observable class ... + + +(===) :: ParEq a => a -> a -> Bool +x === y = case parEq x y of (Just b) -> b + Nothing -> error "might be equal" + +class ParEq a where + parEq :: a -> a -> Maybe Bool + default parEq :: (Generic a, GParEq (Rep a)) => a -> a -> Maybe Bool + parEq x y = gParEq (from x) (from y) + +class GParEq rep where + gParEq :: rep a -> rep a -> Maybe Bool + +orNothing :: IO (Maybe Bool) -> Maybe Bool +orNothing mb = unsafePerformIO $ ourCatchAllIO mb (\_ -> return Nothing) + +catchEq :: Eq a => a -> a -> Maybe Bool +catchEq x y = orNothing $ do mb <- evaluate (x == y); return (Just mb) + +catchGEq :: GParEq rep => rep a -> rep a -> Maybe Bool +catchGEq x y = orNothing $ x `seq` y `seq` (evaluate $ gParEq x y) + +-- Sums: encode choice between constructors +instance (GParEq a, GParEq b) => GParEq (a :+: b) where + gParEq x y = let r = gParEq_ x y in r + where gParEq_ (L1 x) (L1 y) = x `catchGEq` y + gParEq_ (R1 x) (R1 y) = x `catchGEq` y + gParEq_ _ _ = Just False + +-- Products: encode multiple arguments to constructors +instance (GParEq a, GParEq b) => GParEq (a :*: b) where + gParEq x y = let r = gParEq_ x y in r + where gParEq_ (x :*: x') (y :*: y') + | any (== (Just False)) mbs = Just False + | all (== (Just True)) mbs = Just True + | otherwise = Nothing + where mbs = [(catchGEq x y) `seq` (catchGEq x y), (catchGEq x' y') `seq` (catchGEq x' y')] + +-- Unit: used for constructors without arguments +instance GParEq U1 where +#if __GLASGOW_HASKELL__ >= 710 + gParEq x y = catchEq x y +#else + gParEq _ _ = Nothing +#endif + +-- Constants: additional parameters and recursion of kind * +instance (ParEq a) => GParEq (K1 i a) where + gParEq x y = let r = gParEq_ x y in r + where gParEq_ (K1 x) (K1 y) = x `parEq` y + +-- Meta: data types +instance (GParEq a) => GParEq (M1 D d a) where + gParEq x y = let r = gParEq_ x y in r + where gParEq_ (M1 x) (M1 y) = x `catchGEq` y + +-- Meta: Selectors +instance (GParEq a, Selector s) => GParEq (M1 S s a) where + gParEq x y = let r = gParEq_ x y in r + where gParEq_ (M1 x) (M1 y) = x `catchGEq` y + +-- Meta: Constructors +instance (GParEq a, Constructor c) => GParEq (M1 C c a) where + gParEq x y = let r = gParEq_ x y in r + where gParEq_ (M1 x) (M1 y) = x `catchGEq` y + +instance (ParEq a) => ParEq [a] +instance (ParEq a, ParEq b) => ParEq (a,b) +instance (ParEq a) => ParEq (Maybe a) +instance ParEq Int where parEq x y = Just (x == y) +instance ParEq Bool where parEq x y = Just (x == y) +instance ParEq Integer where parEq x y = Just (x == y) +instance ParEq Float where parEq x y = Just (x == y) +instance ParEq Double where parEq x y = Just (x == y) +instance ParEq Char where parEq x y = Just (x == y) diff --git a/Debug/Hoed/Pure.hs b/Debug/Hoed/Pure.hs deleted file mode 100644 --- a/Debug/Hoed/Pure.hs +++ /dev/null @@ -1,366 +0,0 @@ -{-| -Module : Debug.Hoed.Pure -Description : Lighweight algorithmic debugging based on observing intermediate values. -Copyright : (c) 2000 Andy Gill, (c) 2010 University of Kansas, (c) 2013-2015 Maarten Faddegon -License : BSD3 -Maintainer : hoed@maartenfaddegon.nl -Stability : experimental -Portability : POSIX - -Hoed is a tracer and debugger for the programming language Haskell. - -Hoed.Pure is recommended over Hoed.Stk: in contrast to Hoed.Stk you can optimize your program and do not need to enable profiling when using Hoed.Pure. - -To locate a defect with Hoed.Pure you annotate suspected functions and compile as usual. Then you run your program, information about the annotated functions is collected. Finally you connect to a debugging session using a webbrowser. - -Let us consider the following program, a defective implementation of a parity function with a test property. - -> import Test.QuickCheck -> -> isOdd :: Int -> Bool -> isOdd n = isEven (plusOne n) -> -> isEven :: Int -> Bool -> isEven n = mod2 n == 0 -> -> plusOne :: Int -> Int -> plusOne n = n + 1 -> -> mod2 :: Int -> Int -> mod2 n = div n 2 -> -> prop_isOdd :: Int -> Bool -> prop_isOdd x = isOdd (2*x+1) -> -> main :: IO () -> main = printO (prop_isOdd 1) -> -> main :: IO () -> main = quickcheck prop_isOdd - -Using the property-based test tool QuickCheck we find the counter example `1` for our property. - -> ./MyProgram -> *** Failed! Falsifiable (after 1 test): 1 - -Hoed can help us determine which function is defective. We annotate the functions `isOdd`, `isEven`, `plusOne` and `mod2` as follows: - -> import Debug.Hoed.Pure -> -> isOdd :: Int -> Bool -> isOdd = observe "isOdd" isOdd' -> isOdd' n = isEven (plusOne n) -> -> isEven :: Int -> Bool -> isEven = observe "isEven" isEven' -> isEven' n = mod2 n == 0 -> -> plusOne :: Int -> Int -> plusOne = observe "plusOne" plusOne' -> plusOne' n = n + 1 -> -> mod2 :: Int -> Int -> mod2 = observe "mod2" mod2' -> mod2' n = div n 2 -> -> prop_isOdd :: Int -> Bool -> prop_isOdd x = isOdd (2*x+1) -> -> main :: IO () -> main = printO (prop_isOdd 1) - -After running the program a computation tree is constructed and displayed in a web browser. - -> ./MyProgram -> False -> Listening on http://127.0.0.1:10000/ - -After running the program a computation tree is constructed and displayed in a -web browser. You can freely browse this tree to get a better understanding of -your program. If your program misbehaves, you can judge the computation -statements in the tree as 'right' or 'wrong' according to your intention. When -enough statements are judged the debugger tells you the location of the fault -in your code. - -<> - -Read more about Hoed on its project homepage . - -Papers on the theory behind Hoed can be obtained via . - -I am keen to hear about your experience with Hoed: where did you find it useful and where would you like to see improvement? You can send me an e-mail at hoed@maartenfaddegon.nl, or use the github issue tracker . --} - -{-# LANGUAGE CPP #-} - -module Debug.Hoed.Pure - ( -- * Basic annotations - observe - , runO - , printO - , testO - - -- * Property-assisted algorithmic debugging - , runOwp - , printOwp - , testOwp - , Propositions(..) - , PropType(..) - , Proposition(..) - , mkProposition - , ofType - , withSignature - , sizeHint - , withTestGen - , TestGen(..) - , PropositionType(..) - , Module(..) - , Signature(..) - , ParEq(..) - , (===) - , runOstore - , conAp - - -- * Build your own debugger with Hoed - , runO' - , judge - , unjudgedCharacterCount - , CompTree(..) - , Vertex(..) - , CompStmt(..) - , Judge(..) - , Verbosity(..) - - -- * Alternative template Haskell annotations - , observeTempl - , observedTypes - - -- * API to test Hoed itself - , logO - , logOwp - , traceOnly - , UnevalHandler(..) - - -- * The Observable class - , Observer(..) - , Observable(..) - , (<<) - , thunk - , nothunk - , send - , observeOpaque - , observeBase - , constrainBase - , debugO - , CDS(..) - , Generic - ) where - - -import Debug.Hoed.Pure.Observe -import Debug.Hoed.Pure.Render -import Debug.Hoed.Pure.EventForest -import Debug.Hoed.Pure.CompTree -import Debug.Hoed.Pure.DemoGUI -import Debug.Hoed.Pure.Prop -import Debug.Hoed.Pure.Serialize -import Paths_Hoed(getDataDir) - -import Prelude hiding (Right) -import qualified Prelude -import System.Process(system) -import System.IO -import Data.Maybe -import Control.Monad -import Data.List -import Data.Ord -import Data.Char -import System.Environment -import System.Directory(createDirectoryIfMissing) - -import Language.Haskell.TH -import GHC.Generics - -import Data.IORef -import System.IO.Unsafe -import Data.Graph.Libgraph -import Graphics.UI.Threepenny(startGUI,defaultConfig,Config(..)) - -import System.Directory(createDirectoryIfMissing) - - --- %************************************************************************ --- %* * --- \subsection{External start functions} --- %* * --- %************************************************************************ - --- Run the observe ridden code. - - -runOnce :: IO () -runOnce = do - f <- readIORef firstRun - case f of True -> writeIORef firstRun False - False -> error "It is best not to run Hoed more that once (maybe you want to restart GHCI?)" - -firstRun :: IORef Bool -firstRun = unsafePerformIO $ newIORef True - - --- | run some code and return the Trace -debugO :: IO a -> IO Trace -debugO program = - do { runOnce - ; initUniq - ; startEventStream - ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]" - ; ourCatchAllIO (do { program ; return () }) - (hPutStrLn stderr . errorMsg) - ; endEventStream - } - --- | The main entry point; run some IO code, and debug inside it. --- After the IO action is completed, an algorithmic debugging session is started at --- @http://localhost:10000/@ to which you can connect with your webbrowser. --- --- For example: --- --- @ --- main = runO $ do print (triple 3) --- print (triple 2) --- @ - -runO :: IO a -> IO () -runO program = do - (trace,traceInfo,compTree,frt) <- runO' Verbose program - debugSession trace traceInfo compTree frt [] - return () - - --- | Hoed internal function that stores a serialized version of the tree on disk (assisted debugging spawns new instances of Hoed). -runOstore :: String -> IO a -> IO () -runOstore tag program = do - (trace,traceInfo,compTree,frt) <- runO' Silent program - storeTree (treeFilePath ++ tag) compTree - storeTrace (traceFilePath ++ tag) trace - --- | Repeat and trace a failing testcase -testO :: Show a => (a->Bool) -> a -> IO () -testO p x = runO $ putStrLn $ if (p x) then "Passed 1 test." - else " *** Failed! Falsifiable: " ++ show x - --- | Use property based judging. - -runOwp :: [Propositions] -> IO a -> IO () -runOwp ps program = do - (trace,traceInfo,compTree,frt) <- runO' Verbose program - let compTree' = compTree - debugSession trace traceInfo compTree' frt ps - return () - --- | Repeat and trace a failing testcase -testOwp :: Show a => [Propositions] -> (a->Bool) -> a -> IO () -testOwp ps p x = runOwp ps $ putStrLn $ - if (p x) then "Passed 1 test." - else " *** Failed! Falsifiable: " ++ show x - --- | Short for @runO . print@. -printO :: (Show a) => a -> IO () -printO expr = runO (print expr) - - -printOwp :: (Show a) => [Propositions] -> a -> IO () -printOwp ps expr = runOwp ps (print expr) - --- | Only produces a trace. Useful for performance measurements. -traceOnly :: IO a -> IO () -traceOnly program = do - debugO program - return () - - -data Verbosity = Verbose | Silent - -condPutStrLn :: Verbosity -> String -> IO () -condPutStrLn Silent _ = return () -condPutStrLn Verbose msg = hPutStrLn stderr msg - --- |Entry point giving you access to the internals of Hoed. Also see: runO. -runO' :: Verbosity -> IO a -> IO (Trace,TraceInfo,CompTree,EventForest) -runO' verbose program = do - createDirectoryIfMissing True ".Hoed/" - condPutStrLn verbose "=== program output ===\n" - events <- debugO program - condPutStrLn verbose"\n=== program terminated ===" - condPutStrLn verbose"Please wait while the computation tree is constructed..." - - let cdss = eventsToCDS events - let cdss1 = rmEntrySet cdss - let cdss2 = simplifyCDSSet cdss1 - let eqs = renderCompStmts cdss2 - - let frt = mkEventForest events - ti = traceInfo (reverse events) - ds = dependencies ti - ct = mkCompTree eqs ds - - writeFile ".Hoed/Events" (unlines . map show . reverse $ events) -#if defined(TRANSCRIPT) - writeFile ".Hoed/Transcript" (getTranscript events ti) -#endif - - condPutStrLn verbose "\n=== Statistics ===\n" - let e = length events - n = length eqs - b = fromIntegral (length . arcs $ ct ) / fromIntegral ((length . vertices $ ct) - (length . leafs $ ct)) - condPutStrLn verbose $ show e ++ " events" - condPutStrLn verbose $ show n ++ " computation statements" - condPutStrLn verbose $ show ((length . vertices $ ct) - 1) ++ " nodes + 1 virtual root node in the computation tree" - condPutStrLn verbose $ show (length . arcs $ ct) ++ " edges in computation tree" - condPutStrLn verbose $ "computation tree has a branch factor of " ++ show b ++ " (i.e the average number of children of non-leaf nodes)" - - condPutStrLn verbose "\n=== Debug Session ===\n" - return (events, ti, ct, frt) - --- | Trace and write computation tree to file. Useful for regression testing. -logO :: FilePath -> IO a -> IO () -logO filePath program = {- SCC "logO" -} do - (_,_,compTree,_) <- runO' Verbose program - writeFile filePath (showGraph compTree) - return () - - where showGraph g = showWith g showVertex showArc - showVertex RootVertex = ("\".\"","shape=none") - showVertex v = ("\"" ++ (escape . showCompStmt) v ++ "\"", "") - showArc _ = "" - showCompStmt = show . vertexStmt - --- | As logO, but with property-based judging. -logOwp :: UnevalHandler -> FilePath -> [Propositions] -> IO a -> IO () -logOwp handler filePath properties program = do - (trace,traceInfo,compTree,frt) <- runO' Verbose program - hPutStrLn stderr "\n=== Evaluating assigned properties ===\n" - compTree' <- judgeAll handler unjudgedCharacterCount trace properties compTree - writeFile filePath (showGraph compTree') - return () - - where showGraph g = showWith g showVertex showArc - showVertex RootVertex = ("root","") - showVertex v = ("\"" ++ (escape . showCompStmt) v ++ "\"", "") - showArc _ = "" - showCompStmt s = (show . vertexJmt) s ++ ": " ++ (show . vertexStmt) s - ------------------------------------------------------------------------- --- Algorithmic Debugging - -debugSession :: Trace -> TraceInfo -> CompTree -> EventForest -> [Propositions] -> IO () -debugSession trace traceInfo tree frt ps - = do createDirectoryIfMissing True ".Hoed/wwwroot/css" - dataDir <- getDataDir - system $ "cp " ++ dataDir ++ "/img/*png .Hoed/wwwroot/" - system $ "cp " ++ dataDir ++ "/img/*gif .Hoed/wwwroot/" - startGUI defaultConfig - { jsPort = Just 10000 - , jsStatic = Just "./.Hoed/wwwroot" - } (guiMain trace tree frt ps) diff --git a/Debug/Hoed/Pure/CompTree.hs b/Debug/Hoed/Pure/CompTree.hs deleted file mode 100644 --- a/Debug/Hoed/Pure/CompTree.hs +++ /dev/null @@ -1,409 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon, 2015 - -{-# LANGUAGE CPP, DeriveGeneric #-} - -module Debug.Hoed.Pure.CompTree -( CompTree -, Vertex(..) -, mkCompTree -, isRootVertex -, vertexUID -, vertexRes -, replaceVertex -, getJudgement -, setJudgement -, isRight -, isWrong -, isUnassessed -, isAssisted -, isInconclusive -, isPassing -, leafs -, ConstantValue(..) -, getLocation -, unjudgedCharacterCount -#if defined(TRANSCRIPT) -, getTranscript -#endif -, TraceInfo(..) -, traceInfo -, Graph(..) -- re-export from LibGraph -)where - -import Debug.Hoed.Pure.Render -import Debug.Hoed.Pure.Observe -import Debug.Hoed.Pure.EventForest - -import Prelude hiding (Right) -import Data.Graph.Libgraph -import Data.List(nub,delete,(\\)) -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import GHC.Generics - -data Vertex = RootVertex | Vertex {vertexStmt :: CompStmt, vertexJmt :: Judgement} - deriving (Eq,Show,Ord,Generic) - -getJudgement :: Vertex -> Judgement -getJudgement RootVertex = Right -getJudgement v = vertexJmt v - -setJudgement :: Vertex -> Judgement -> Vertex -setJudgement RootVertex _ = RootVertex -setJudgement v j = v{vertexJmt=j} - -isRight v = getJudgement v == Right -isWrong v = getJudgement v == Wrong -isUnassessed v = getJudgement v == Unassessed -isAssisted v = case getJudgement v of (Assisted _) -> True; _ -> False - -isInconclusive v = case getJudgement v of - (Assisted ms) -> any isInconclusive' ms - _ -> False -isInconclusive' (InconclusiveProperty _) = True -isInconclusive' _ = False - -isPassing v = case getJudgement v of - (Assisted ms) -> any isPassing' ms - _ -> False -isPassing' (PassingProperty _) = True -isPassing' _ = False - -vertexUID :: Vertex -> UID -vertexUID RootVertex = -1 -vertexUID (Vertex s _) = stmtIdentifier s - -vertexRes :: Vertex -> String -vertexRes RootVertex = "RootVertex" -vertexRes v = stmtRes . vertexStmt $ v - --- | The forest of computation trees. Also see the Libgraph library. -type CompTree = Graph Vertex () - -isRootVertex :: Vertex -> Bool -isRootVertex RootVertex = True -isRootVertex _ = False - -leafs :: CompTree -> [Vertex] -leafs g = filter (\v -> succs g v == []) (vertices g) - --- | Approximates the complexity of a computation tree by summing the length --- of the unjudged computation statements (i.e not Right or Wrong) in the tree. -unjudgedCharacterCount :: CompTree -> Int -unjudgedCharacterCount = sum . (map characterCount) . (filter unjudged) . vertices - where characterCount = length . stmtLabel . vertexStmt - -unjudged = not . judged -judged v = (isRight v || isWrong v) - -replaceVertex :: CompTree -> Vertex -> CompTree -replaceVertex g v = mapGraph f g - where f RootVertex = RootVertex - f v' | (vertexUID v') == (vertexUID v) = v - | otherwise = v' - --------------------------------------------------------------------------------- --- Computation Tree - --- One computation statement can have multiple result-events. Sometime these add --- new information, often the information is just a duplicate of what we already --- know. With nub we remove the duplicates. - -mkCompTree :: [CompStmt] -> [(UID,UID)] -> CompTree -mkCompTree cs ds = Graph RootVertex (vs) as - - where vs = RootVertex : map (\cs -> Vertex cs Unassessed) cs - as = map (\(i,j) -> Arc (findVertex i) (findVertex j) ()) (nub ds) - - -- A mapping from stmtUID to Vertex of all CompStmts in cs - vMap :: IntMap Vertex - -- vMap = foldl (\m c -> let v = Vertex c Unassessed in foldl (\m' i -> IntMap.insert i v m') m (stmtUIDs c)) IntMap.empty cs - vMap = foldl (\m c -> IntMap.insert (stmtIdentifier c) (Vertex c Unassessed) m) IntMap.empty cs - - -- Given an UID, get corresponding CompStmt (wrapped in a Vertex) - findVertex :: UID -> Vertex - findVertex (-1) = RootVertex - findVertex a = case IntMap.lookup a vMap of - Nothing -> error $ "mkCompTree: Error, cannot find a statement with UID " ++ show a ++ "!\n" - ++ "We recorded statements with the following UIDs: " ++ (show . IntMap.keys) vMap ++ "\n" - ++ unlines (map (\c -> (show . stmtIdentifier) c ++ ": " ++ show c) cs) - (Just v) -> v - ------------------------------------------------------------------------------------------------------------------------- - -data ConstantValue = ConstantValue { valStmt :: UID, valLoc :: Location - , valMin :: UID, valMax :: UID } - | CVRoot - deriving Eq - -instance Show ConstantValue where - show CVRoot = "Root" - show v = "Stmt-" ++ (show . valStmt $ v) - ++ "-" ++ (show . valLoc $ v) - ++ ": " ++ (show . valMin $ v) - ++ "-" ++ (show . valMax $ v) - ------------------------------------------------------------------------------------------------------------------------- - --- Add element x to the head of the list at key k. -insertCon :: Int -> a -> IntMap [a] -> IntMap [a] -insertCon k x = IntMap.insertWith (\[x'] xs->x':xs) k [x] -- where x == x' - ------------------------------------------------------------------------------------------------------------------------- - -data TraceInfo = TraceInfo - { topLvlFun :: IntMap UID - -- references from the UID of an event to the UID of the corresponding top-level Fun event - , locations :: IntMap (ParentPosition -> Bool) - -- reference from parent UID and position to location - , computations :: Nesting - -- UIDs of active and paused computations of arguments/results of Fun events -#if defined(TRANSCRIPT) - , messages :: IntMap String - -- stored depth of the stack for every event -#endif - , storedStack :: IntMap [UID] - -- reference from parent UID and position to previous stack - , dependencies :: [(UID,UID)] - } -- the result - - ------------------------------------------------------------------------------------------------------------------------- -#if defined(TRANSCRIPT) -addMessage :: Event -> String -> TraceInfo -> TraceInfo -addMessage e msg s = s{ messages = (flip $ IntMap.insert i) (messages s) $ case IntMap.lookup i (messages s) of - Nothing -> msg - (Just msg') -> msg' ++ ", " ++ msg } - - where i = eventUID e - - -getMessage :: Event -> TraceInfo -> String -getMessage e s = case IntMap.lookup i (messages s) of - Nothing -> "" - (Just msg) -> msg - - where i = eventUID e - -getTranscript :: [Event] -> TraceInfo -> String -getTranscript es t = foldl (\acc e -> (show e ++ m e) ++ "\n" ++ acc) "" es - - where m e = case IntMap.lookup (eventUID e) ms of - Nothing -> "" - (Just msg) -> "\n " ++ msg - - ms = messages t -#endif ------------------------------------------------------------------------------------------------------------------------- - -getLocation :: Event -> TraceInfo -> Bool -getLocation e s = getLocation' p - - where p = parentPosition . eventParent $ e - j = (parentUID . eventParent $ e) - (Just getLocation') = (IntMap.lookup j (locations s)) - -setLocation :: Event -> (ParentPosition -> Bool) -> TraceInfo -> TraceInfo -setLocation e getLoc s = s{locations=IntMap.insert i getLoc (locations s)} - - where i = eventUID e - ------------------------------------------------------------------------------------------------------------------------- - --- When we see a Fun event whose parent is not a Fun event it is a top level Fun event, --- otherwise just copy the reference to the top level Fun event from the parent. --- A top leven Fun event references itself. -seeFun :: Event -> TraceInfo -> TraceInfo -seeFun e s = s{ topLvlFun=case IntMap.lookup j (topLvlFun s) of - Nothing -> IntMap.insert i i (topLvlFun s) - (Just a) -> IntMap.insert i a (topLvlFun s) - } - - where i = eventUID e - j = parentUID . eventParent $ e - --- Get the UID of the top-level Fun of the parent of event e -getTopLvlFun :: Event -> TraceInfo -> UID -getTopLvlFun e s = case IntMap.lookup j (topLvlFun s) of Nothing -> j; (Just a') -> a' - - where j = parentUID . eventParent $ e - --- Copy top-level Fun reference from the parent of e -cpyTopLvlFun :: Event -> TraceInfo -> TraceInfo -cpyTopLvlFun e s = s{topLvlFun=IntMap.insert i a (topLvlFun s)} - - where i = eventUID e - a = getTopLvlFun e s - ------------------------------------------------------------------------------------------------------------------------- - -data Span = Computing UID | Paused UID -type Nesting = [Span] - -instance Show Span where - show (Computing i) = show i - show (Paused i) = "(" ++ show i ++ ")" - -showCs :: [Span] -> String -showCs [] = "< >" -showCs [c] = "< " ++ show c ++ " >" -showCs (c:cs) = foldl (\s c' -> s ++ ", " ++ show c') ("< " ++ show c) cs ++ " >" - -getSpanUID (Computing j) = j -getSpanUID (Paused j) = j - -isSpan :: UID -> Span -> Bool -isSpan i s = i == getSpanUID s - -start :: Event -> TraceInfo -> TraceInfo -start e s = m s{computations = cs} - - where i = getTopLvlFun e s - cs = Computing i : computations s -#if defined(TRANSCRIPT) - m = addMessage e $ "Start computation " ++ show i ++ ": " ++ showCs cs -#else - m = id -#endif - - -stop :: Event -> TraceInfo -> TraceInfo -stop e s = m s{computations = cs} - - where i = getTopLvlFun e s - cs = deleteFirst (computations s) - deleteFirst [] = [] - deleteFirst (s:ss) | isSpan i s = ss - | otherwise = s : deleteFirst ss -#if defined(TRANSCRIPT) - m = addMessage e $ "Stop computation " ++ show i ++ ": " ++ showCs cs -#else - m = id -#endif - - -pause :: Event -> TraceInfo -> TraceInfo -pause e s = m s{computations=cs} - - where i = getTopLvlFun e s - cs = case cs_post of - [] -> cs_pre - (c:cs') -> cs_pre ++ (Paused i) : cs' - (cs_pre,cs_post) = break isComputingI (computations s) - isComputingI (Computing j) = i == j - isComputingI _ = False -#if defined(TRANSCRIPT) - m = addMessage e $ "Pause computation " ++ show i ++ ": " ++ showCs cs -#else - m = id -#endif - -resume :: Event -> TraceInfo -> TraceInfo -resume e s = m s{computations=cs} - - where i = getTopLvlFun e s - cs = case cs_post of - [] -> cs_pre - (c:cs') -> cs_pre ++ (Computing i) : cs' - (cs_pre,cs_post) = break isPausedI (computations s) - isPausedI (Paused j) = i == j - isPausedI _ = False -#if defined(TRANSCRIPT) - m = addMessage e $ "Resume computation " ++ show i ++ ": " ++ showCs cs -#else - m = id -#endif - -activeComputations :: TraceInfo -> [UID] -activeComputations s = map getSpanUID . filter isActive $ computations s - where isActive (Computing _) = True - isActive _ = False - - ------------------------------------------------------------------------------------------------------------------------- - -addDependency :: Event -> TraceInfo -> TraceInfo -addDependency e s = m s{dependencies = case d of (Just d') -> d':dependencies s; Nothing -> dependencies s} - - where d = case activeComputations s of - [] -> Nothing - [n] -> Just (-1,n) -- top-level function detected (may later add dependency from Root) - (n:m:_) -> Just (m,n) - -#if defined(TRANSCRIPT) - m = case d of - Nothing -> addMessage e ("does not add dependency") - (Just d') -> addMessage e ("adds dependency " ++ show (fst d') ++ " -> " ++ show (snd d')) -#else - m = id -#endif - ------------------------------------------------------------------------------------------------------------------------- - -type ConsMap = IntMap [ParentPosition] - --- Iff an event is a constant then the UID of its parent and its ParentPosition --- are elements of the ConsMap. -mkConsMap :: Trace -> ConsMap -mkConsMap = foldl loop IntMap.empty - where loop :: IntMap [ParentPosition] -> Event -> IntMap [ParentPosition] - loop m e = case change e of - Cons{} -> insertCon (parentUID . eventParent $ e) (parentPosition . eventParent $ e) m - _ -> m - --- Return True for an enter event corresponding to a constant event and for any constant event, return False otherwise. -corToCons :: ConsMap -> Event -> Bool -corToCons cs e = case IntMap.lookup j cs of - Nothing -> False - (Just ps) -> p `elem` ps - where j = (parentUID . eventParent $ e) - p = parentPosition . eventParent $ e - ------------------------------------------------------------------------------------------------------------------------- - -traceInfo :: Trace -> TraceInfo -traceInfo trc = foldl loop s0 trc - - where s0 :: TraceInfo - s0 = TraceInfo IntMap.empty IntMap.empty [] -#if defined(TRANSCRIPT) - IntMap.empty -#endif - IntMap.empty [] - - cs :: ConsMap - cs = mkConsMap trc - - loop :: TraceInfo -> Event -> TraceInfo - loop s e = let loc = getLocation e s - in case change e of - Observe{} -> setLocation e (\_->True) s - - Fun{} -> setLocation e (\q->case q of 0 -> not loc; 1 -> loc) - . seeFun e $ s - - -- Span start - Enter{} -> if not . corToCons cs $ e then s else cpyTopLvlFun e - $ case loc of - True -> addDependency e - $ start e s - False -> pause e s - - NoEnter{} -> if not . corToCons cs $ e then s else cpyTopLvlFun e - $ case loc of - True -> addDependency e - $ start e s - False -> pause e s - - -- Span end - Cons{} -> cpyTopLvlFun e - . setLocation e (\_->loc) - $ case loc of - True -> stop e s - False -> resume e s - - evnt -> error $ "traceInfo.loop cannot handle " ++ show evnt diff --git a/Debug/Hoed/Pure/DemoGUI.hs b/Debug/Hoed/Pure/DemoGUI.hs deleted file mode 100644 --- a/Debug/Hoed/Pure/DemoGUI.hs +++ /dev/null @@ -1,713 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon, 2014-2015 -{-# LANGUAGE CPP #-} - -module Debug.Hoed.Pure.DemoGUI (guiMain,treeFilePath) -where - -import qualified Prelude -import Prelude hiding(Right) -import Debug.Hoed.Pure.Render -import Debug.Hoed.Pure.CompTree -import Debug.Hoed.Pure.EventForest -import Debug.Hoed.Pure.Observe -import Debug.Hoed.Pure.Serialize -import qualified Debug.Hoed.Pure.Prop as Prop -import Debug.Hoed.Pure.Prop(Propositions,lookupPropositions,UnevalHandler(..),Judge(..),treeFilePath) -import Paths_Hoed (version) -import Data.Version (showVersion) -import Data.Graph.Libgraph -import qualified Graphics.UI.Threepenny as UI -import Graphics.UI.Threepenny (startGUI,defaultConfig, Window, UI, (#), (#+), (#.), string, on,get,set) -import System.Process(system) -import Data.IORef -import Text.Regex.Posix -import Text.Regex.Posix.String -import Data.Time.Clock -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.List(findIndex,intersperse,nub,sort,sortBy -#if __GLASGOW_HASKELL__ >= 710 - , sortOn -#endif - ) - -#if __GLASGOW_HASKELL__ < 710 -sortOn :: Ord b => (a -> b) -> [a] -> [a] -sortOn f = map snd . sortOn' fst . map (\x -> (f x, x)) - -sortOn' :: Ord b => (a -> b) -> [a] -> [a] -sortOn' f = sortBy (\x y -> compare (f x) (f y)) -#endif - -type Next = CompTree -> (Vertex -> Judgement) -> Vertex - --------------------------------------------------------------------------------- --- The tabbed layout from which we select the different views - -guiMain :: Trace -> CompTree -> EventForest -> [Propositions] -> Window -> UI () -guiMain trace tree frt propositions window - = do return window # set UI.title "Hoed debugging session" - - -- memory shared between the different views - compTreeRef <- UI.liftIO $ newIORef tree - traceRef <- UI.liftIO $ newIORef trace - - -- Get a list of vertices from the computation graph - let ns = filter (not . isRootVertex) (preorder tree) - - -- Shared memory - currentVertexRef <- UI.liftIO $ newIORef (vertexUID . head $ ns) - regexRef <- UI.liftIO $ newIORef "" - imgCountRef <- UI.liftIO $ newIORef (0 :: Int) - - -- Tabs to select which pane to display - tab1 <- UI.button # set UI.text "About" # set UI.style activeTab - tab2 <- UI.button # set UI.text "Observe" # set UI.style otherTab - tab3 <- UI.button # set UI.text "Algorithmic Debugging" # set UI.style otherTab - tab4 <- UI.button # set UI.text "Assisted Debugging" # set UI.style otherTab - tab5 <- UI.button # set UI.text "Explore" # set UI.style otherTab - tab6 <- UI.button # set UI.text "Stats" # set UI.style otherTab - logo <- UI.img # set UI.src "static/hoed-logo.png" # set UI.style [("float","right"), ("height","2.2em")] - tabs <- UI.div # set UI.style [("background-color","#D3D3D3")] #+ (map return [tab1,tab2,tab3,tab4,tab5,tab6,logo]) - - let coloActive tab = do mapM_ (\t -> (return t) # set UI.style otherTab) [tab1,tab2,tab3,tab4,tab5,tab6]; return tab # set UI.style activeTab - - help <- guiHelp # set UI.style [("margin-top","0.5em")] - on UI.click tab1 $ \_ -> do - coloActive tab1 - UI.getBody window # set UI.children [tabs,help] - on UI.click tab2 $ \_ -> do - coloActive tab2 - pane <- guiObserve compTreeRef currentVertexRef # set UI.style [("margin-top","0.5em")] - UI.getBody window # set UI.children [tabs,pane] - on UI.click tab3 $ \_ -> do - coloActive tab3 - pane <- guiAlgoDebug compTreeRef currentVertexRef regexRef imgCountRef # set UI.style [("margin-top","0.5em")] - UI.getBody window # set UI.children [tabs,pane] - on UI.click tab4 $ \_ -> do - coloActive tab4 - pane <- guiAssisted traceRef propositions compTreeRef currentVertexRef regexRef imgCountRef # set UI.style [("margin-top","0.5em")] - UI.getBody window # set UI.children [tabs,pane] - on UI.click tab5 $ \_ -> do - coloActive tab5 - pane <- guiExplore compTreeRef currentVertexRef regexRef imgCountRef # set UI.style [("margin-top","0.5em")] - UI.getBody window # set UI.children [tabs,pane] - on UI.click tab6 $ \_ -> do - coloActive tab6 - pane <- guiStats compTreeRef - UI.getBody window # set UI.children [tabs,pane] - - UI.getBody window # set UI.style [("margin","0")] #+ (map return [tabs,help]) - return () - - -activeTab = ("background-color", "white") : tabstyle -otherTab = ("background-color", "#f0f0f0") : tabstyle -tabstyle = [("-webkit-border-top-left-radius", "19"), ("-moz-border-top-left-radius", "19"), ("border-top-left-radius", "0.5em"),("-webkit-border-top-right-radius", "19"), ("-moz-border-top-right-radius", "19"), ("border-top-right-radius", "0.5em"), ("border-width", "medium medium 0px"),("margin-top","1em")] - --------------------------------------------------------------------------------- --- The help/welcome page - -guiHelp :: UI UI.Element -guiHelp = UI.div # set UI.style [("margin-left", "20%"),("margin-right", "20%")] #+ - [ UI.h1 # set UI.text ("Welcome to Hoed " ++ showVersion version) - , UI.p # set UI.text "Hoed is a tracer and debugger for the language Haskell. You can trace a program by annotating functions in suspected modules. After running the program the trace can be viewed in different ways using a web browser. Use the tabs at the top of this page to select the view you want to use. Below we give a short explenation of each view." - , UI.h2 # set UI.text "Observe" - , UI.p # set UI.text "The observe view is useful to get a first impression of what is happening in your program, or to get an overview of the computation statements of a particular slice or pattern. At the top the list of slices and for each slice how many times it was reduced. Below the line a list of computation statements." - , UI.h2 # set UI.text "Algorithmic Debugging" - , UI.p # set UI.text "The algorithmic debugger shows you recorded computation statements, that is a function applied to an argument and its result. You judge these statements as right or wrong. When enough statements are judged the debugger tells you the location of the fault in your code." - , UI.h2 # set UI.text "Explore" - , UI.p # set UI.text "The trace is translated into a tree of computation statements for the algorithmic debugging view. In the explore view you can freely browse this tree to get a better understanding of your program. You can decide yourself in which order you want to judge statements. When enough statements are judged the debugger tells you the location of the fault in your code." - ] - --------------------------------------------------------------------------------- --- The statistics GUI - -guiStats :: IORef CompTree -> UI UI.Element -guiStats compTreeRef = do - (Graph _ vs as) <- UI.liftIO $ readIORef compTreeRef - - sec1 <- UI.h3 # set UI.text "Computation Tree Statistics" - -- Minus 1 for the root node - vcount <- UI.div # set UI.text (show ((length vs) - 1) ++ " computation statements") - -- TODO: Should we subtract the dependencies from the root node? - acount <- UI.div # set UI.text (show (length as) ++ " dependencies") - - sec2 <- UI.h3 # set UI.text "Judgements" - -- Minus 1 for the root node that is always considered as right - rightCount <- UI.div # set UI.text ((show $ (length . filter isRight $ vs) - 1) ++ " Right") - wrongCount <- UI.div # set UI.text ((show . length . filter isWrong $ vs) ++ " Wrong") - assCount <- UI.div # set UI.text ((show . length . filter isAssisted $ vs) ++ " Assisted") - incon <- UI.div # set UI.text ((show . length . filter isInconclusive $ vs) ++ " Inconclusive") # set UI.style [("margin-left","2em")] - - passing <- UI.div # set UI.text ((show . length . filter isPassing $ vs) ++ " Passing") # set UI.style [("margin-left","2em")] - unassCount <- UI.div # set UI.text ((show . length . filter isUnassessed $ vs) ++ " Unassessed") - - UI.div # set UI.style [("margin-left", "20%"),("margin-right", "20%")] #+ (map return [sec1,vcount,acount, sec2, rightCount, wrongCount, assCount, incon, passing, unassCount]) - --------------------------------------------------------------------------------- --- The observe GUI - -guiObserve :: IORef CompTree -> IORef Int -> UI UI.Element -guiObserve compTreeRef currentVertexRef = do - (Graph _ vs _) <- UI.liftIO $ readIORef compTreeRef - - -- Alphabetical sorted list of slices, and for each slice how many computation statements - -- there are for that slice - let slices' = sort $ map (stmtLabel . vertexStmt) . filter (not . isRootVertex) $ vs - slices = nub slices' - count slice = length (filter (==slice) slices') - span s = UI.span # set UI.text s # set UI.style [("margin-right","1em")] - spans = map (\(c,lbl) -> span $ show c ++ " " ++ lbl) $ zip (map count slices) slices - - -- Alphabetical sorted list of computation statements - let vs_sorted = sortOn (vertexRes) . filter (not . isRootVertex) $ vs - stmtDiv <- UI.form # set UI.style [("margin-left","2em")] - updateRegEx currentVertexRef vs_sorted stmtDiv "" -- with empty regex to fill div3 1st time - - -- The regexp filter - regexRef <- UI.liftIO $ newIORef "" - matchField <- UI.input - matchButton <- UI.button # UI.set UI.text "search" - -- Uncomment next line to search automatically when the user changes the regex - -- on UI.valueChange matchField (updateRegEx currentVertexRef vs_sorted stmtDiv) - on UI.valueChange matchField $ \s -> UI.liftIO $ writeIORef regexRef s - on UI.click matchButton $ \_ -> do - r <- UI.liftIO $ readIORef regexRef - updateRegEx currentVertexRef vs_sorted stmtDiv r - - UI.div #+ (spans ++ [UI.hr, UI.span # set UI.text "regex filter: ", return matchField, return matchButton, UI.hr, return stmtDiv]) - -updateRegEx :: IORef Int -> [Vertex] -> UI.Element -> String -> UI () -updateRegEx currentVertexRef vs stmtDiv r = do - (return stmtDiv) # set UI.text "Applying filter ..." - rComp <- UI.liftIO $ compile defaultCompOpt defaultExecOpt r - case rComp of Prelude.Right _ -> drawR - Prelude.Left (_, errorMessage) -> drawL errorMessage - return () - - where - drawL m = do (return stmtDiv) # set UI.text m - drawR - | vs_filtered == [] = drawL $ "There are no computation statements matching \"" ++ r ++ "\"." - | otherwise = (return stmtDiv) # set UI.children [] #+ csDivs - - vs_filtered = if r == "" then vs else filter (\v -> (noNewlines . vertexRes $ v) =~ r) vs - - csDivs = map stmtToDiv vs_filtered - - stmtToDiv v = do - i <- UI.liftIO $ readIORef currentVertexRef - s <- UI.span # set UI.text (vertexRes v) - r <- UI.input # set UI.type_ "radio" # set UI.checked (i == vertexUID v) - let src | isRight v = "static/right.png" - | isWrong v = "static/wrong.png" - | otherwise = "static/unassessed.png" - j <- UI.img # set UI.src src # set UI.height 20 # set UI.style [("margin-left","1em")] - on UI.checkedChange r $ \_ -> checked v - UI.div #+ map return [r,s,j] - - checked v = do - UI.liftIO $ writeIORef currentVertexRef (vertexUID v) - drawR - --------------------------------------------------------------------------------- --- The Assisted Debugging GUI - -guiAssisted :: IORef Trace -> [Propositions] -> IORef CompTree -> IORef Int -> IORef String -> IORef Int -> UI UI.Element -guiAssisted traceRef ps compTreeRef currentVertexRef regexRef imgCountRef = do - - handlerRef <- UI.liftIO $ newIORef Bottom - nextRef <- UI.liftIO $ newIORef (next_step :: Next) - - -- Get a list of vertices from the computation tree - tree <- UI.liftIO $ readIORef compTreeRef - - -- Status - status <- UI.span - updateStatus status compTreeRef - - -- Field to show current computation statement to the programmer - compStmt <- UI.pre # set UI.style [("margin","0 2em")] - showStmt compStmt compTreeRef currentVertexRef - - -- Buttons to judge the current statement - right <- UI.button # UI.set UI.text "right " #+ [UI.img # set UI.src "static/right.png" # set UI.height 20] # set UI.style [("margin-right","1em")] - wrong <- UI.button # set UI.text "wrong " #+ [UI.img # set UI.src "static/wrong.png" # set UI.height 20] # set UI.style [("margin-right","1em")] - let j = judge AdvanceToNext status compStmt Nothing Nothing currentVertexRef compTreeRef nextRef - j right Right - j wrong Wrong - let lightBulbs n = take n . repeat $ UI.img # set UI.src "static/test.png" # set UI.height 20 - - test1B <- UI.button # set UI.text "test" #+ lightBulbs 1 # set UI.style [("margin-right","1em")] - testChB <- UI.button # set UI.text "test" #+ lightBulbs 2 # set UI.style [("margin-right","1em")] - testAllB <- UI.button # set UI.text "test" #+ lightBulbs 3 # set UI.style [("margin-right","1em")] - resetB <- UI.button # set UI.text "clear all" # set UI.height 20 - on UI.click test1B $ \_ -> testCurrent compTreeRef traceRef ps status currentVertexRef compStmt handlerRef nextRef - on UI.click testChB $ \_ -> testCurrentAndChildren compTreeRef traceRef ps status currentVertexRef compStmt handlerRef nextRef - on UI.click testAllB $ \_ -> testAll compTreeRef traceRef ps status currentVertexRef compStmt handlerRef nextRef - on UI.click resetB $ \_ -> resetTree compTreeRef ps status currentVertexRef compStmt nextRef - - -- strategy buttons - singleStep <- UI.input # set UI.type_ "radio" # set UI.checked True - divideQuery <- UI.input # set UI.type_ "radio" # set UI.checked False - on UI.checkedChange singleStep $ \_ -> do - return divideQuery # set UI.checked False - UI.liftIO $ writeIORef nextRef next_step - advance AdvanceToNext status compStmt Nothing Nothing currentVertexRef compTreeRef nextRef - on UI.checkedChange divideQuery $ \_ -> do - return singleStep # set UI.checked False - UI.liftIO $ writeIORef nextRef next_daq - advance AdvanceToNext status compStmt Nothing Nothing currentVertexRef compTreeRef nextRef - - -- Populate the main screen - top <- UI.center #+ [return status, UI.br, return right, return wrong, return test1B, return testChB, return testAllB, return resetB] - top2 <- UI.center #+ [ UI.span # set UI.text "strategy: " # set UI.style [("margin-right","1em")] - , return singleStep, UI.span # set UI.text "single step" # set UI.style [("margin-right","1em")] - , return divideQuery, UI.span # set UI.text "divide & query"] - UI.div #+ [return top, return top2, UI.hr, return compStmt] - -resetTree compTreeRef ps status currentVertexRef compStmt nextRef = do - t <- UI.liftIO $ readIORef compTreeRef - UI.liftIO $ writeIORef compTreeRef (mapGraph resetVertex t) - advance AdvanceToNext status compStmt Nothing Nothing currentVertexRef compTreeRef nextRef - where resetVertex = flip setJudgement Unassessed - -testCurrent :: IORef CompTree -> IORef Trace -> [Propositions] -> UI.Element -> IORef Int -> UI.Element -> t -> IORef Next -> UI () -testCurrent compTreeRef traceRef ps status currentVertexRef compStmt handlerRef nextRef= do - return status # UI.set UI.text "Evaluating propositions ..." #+ [UI.img # set UI.src "static/loading.gif" # set UI.height 30] - mcv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - case mcv of - Nothing -> updateStatus status compTreeRef - (Just cv) -> do - time1 <- UI.liftIO getCurrentTime - test1 cv compTreeRef traceRef ps handlerRef (onNoProps cv) onJudge onTreeSwitch - time2 <- UI.liftIO getCurrentTime - UI.liftIO $ putStrLn ("tested computation statement in " ++ show (diffUTCTime time2 time1)) - where - onNoProps cv = do - UI.element status # set UI.text ("Cannot test: no propositions associated with function " ++ (stmtLabel . vertexStmt) cv ++ "!") - return () - onJudge = - advance AdvanceToNext status compStmt Nothing Nothing currentVertexRef compTreeRef nextRef - onTreeSwitch :: CompTree -> Trace -> UI () - onTreeSwitch newCompTree newTrace = do - UI.liftIO $ writeIORef compTreeRef newCompTree - UI.liftIO $ writeIORef traceRef newTrace - advance AdvanceToNext status compStmt Nothing Nothing currentVertexRef compTreeRef nextRef - return status # UI.set UI.text "Discovered and switched to a simpler computatation tree!" #+ [UI.img # set UI.src "static/test.png" # set UI.height 30] - return () - -testCurrentAndChildren compTreeRef traceRef ps status currentVertexRef compStmt handlerRef nextRef = do - return status # UI.set UI.text "Evaluating propositions ..." #+ [UI.img # set UI.src "static/loading.gif" # set UI.height 30] - mcv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - compTree <- UI.liftIO $ readIORef compTreeRef - case mcv of - Nothing -> updateStatus status compTreeRef - (Just cv) -> do - let vs = cv : succs compTree cv - time1 <- UI.liftIO getCurrentTime - switchedTree <- testMany vs compTreeRef traceRef ps handlerRef - time2 <- UI.liftIO getCurrentTime - UI.liftIO $ putStrLn ("tested " ++ show (length vs) ++ " computation statements in " ++ show (diffUTCTime time2 time1)) - advance AdvanceToNext status compStmt Nothing Nothing currentVertexRef compTreeRef nextRef - if switchedTree - then do - return status # UI.set UI.text "Discovered and switched to a simpler computatation tree!" #+ [UI.img # set UI.src "static/test.png" # set UI.height 30] - return () - else - return () - -testAll compTreeRef traceRef ps status currentVertexRef compStmt handlerRef nextRef = do - return status # UI.set UI.text "Evaluating propositions ..." #+ [UI.img # set UI.src "static/loading.gif" # set UI.height 30] - mcv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - compTree <- UI.liftIO $ readIORef compTreeRef - let vs = vertices compTree - time1 <- UI.liftIO getCurrentTime - switchedTree <- testMany vs compTreeRef traceRef ps handlerRef - time2 <- UI.liftIO getCurrentTime - UI.liftIO $ putStrLn ("tested " ++ show (length vs) ++ " computation statements in " ++ show (diffUTCTime time2 time1)) - advance AdvanceToNext status compStmt Nothing Nothing currentVertexRef compTreeRef nextRef - if switchedTree - then do - return status # UI.set UI.text "Discovered and switched to a simpler computatation tree!" #+ [UI.img # set UI.src "static/test.png" # set UI.height 30] - return () - else - return () - -testMany :: [Vertex] -> IORef CompTree -> IORef Trace -> [Propositions] -> t -> UI Bool -testMany vs compTreeRef traceRef ps handlerRef = case vs of - [] -> return False - (v:vs') -> do - continue <- test1 v compTreeRef traceRef ps handlerRef (onNoProps v) onJudge onTreeSwitch - if continue then testMany vs' compTreeRef traceRef ps handlerRef - else return True - where - onNoProps _ = - return True - onJudge = - return True - onTreeSwitch newCompTree newTrace = do - UI.liftIO $ writeIORef compTreeRef newCompTree - UI.liftIO $ writeIORef traceRef newTrace - UI.liftIO $ putStrLn $ "Switched to a simpler computation tree!" - return False - -test1 :: Vertex -> IORef CompTree -> IORef Trace -> [Propositions] -> t -> UI b -> UI b -> (CompTree -> Trace -> UI b) -> UI b -test1 vertex compTreeRef traceRef ps handlerRef onNoProps onJudge onTreeSwitch = do - compTree <- UI.liftIO $ readIORef compTreeRef - mj <- test1' vertex compTree traceRef ps handlerRef - case mj of - Nothing -> onNoProps - (Just j) -> case j of - (Judge jmt) -> do - UI.liftIO $ putStrLn $ "conclusion: statement is " ++ show jmt - UI.liftIO $ writeIORef compTreeRef (replaceVertex compTree (setJudgement vertex jmt)) - onJudge - (AlternativeTree compTree' trace') -> do - onTreeSwitch compTree' trace' - -test1' :: Vertex -> CompTree -> IORef Trace -> [Propositions] -> t -> UI (Maybe Judge) -test1' v compTree traceRef ps handlerRef = do - case lookupPropositions ps v of - Nothing -> - return Nothing - (Just p) -> do - trace <- UI.liftIO $ readIORef traceRef - j <- UI.liftIO $ Prop.judge trace p v unjudgedCharacterCount compTree - return (Just j) - - --------------------------------------------------------------------------------- --- The Algorithmic Debugging GUI - -guiAlgoDebug :: IORef CompTree -> IORef Int -> IORef String -> IORef Int -> UI UI.Element -guiAlgoDebug compTreeRef currentVertexRef regexRef imgCountRef = do - nextRef <- UI.liftIO $ newIORef (next_step :: Next) - - -- Get a list of vertices from the computation tree - tree <- UI.liftIO $ readIORef compTreeRef - - -- Status - status <- UI.span - updateStatus status compTreeRef - - -- Field to show computation statement(s) of current vertex - compStmt <- UI.pre # set UI.style [("margin","0 2em")] - showStmt compStmt compTreeRef currentVertexRef - - -- Buttons to judge the current statement - right <- UI.button # UI.set UI.text "right " #+ [UI.img # set UI.src "static/right.png" # set UI.height 30] # set UI.style [("margin-right","1em")] - wrong <- UI.button # set UI.text "wrong " #+ [UI.img # set UI.src "static/wrong.png" # set UI.height 30] - let j = judge AdvanceToNext status compStmt Nothing Nothing currentVertexRef compTreeRef nextRef - j right Right - j wrong Wrong - - -- Populate the main screen - top <- UI.center #+ [return status, UI.br, return right, return wrong] - UI.div #+ [return top, UI.hr, return compStmt] - --------------------------------------------------------------------------------- --- Judge a computation statement, shared between the algorithmic debugging --- view and explore view. - -data Advance = AdvanceToNext | DoNotAdvance - -judge :: Advance -> UI.Element -> UI.Element -> Maybe UI.Element -> Maybe (UI.Element,IORef Int) - -> IORef UID -> IORef CompTree -> IORef Next -> UI.Element -> Judgement -> UI () -judge adv status compStmt mMenu mImg currentVertexRef compTreeRef nextRef b j = - on UI.click b $ \_ -> do - mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - case mv of - (Just v) -> judge' v - Nothing -> return () - where - judge' :: Vertex -> UI () - judge' v = do - t' <- UI.liftIO $ readIORef compTreeRef - UI.liftIO $ writeIORef compTreeRef (markNode t' v j) - advance adv status compStmt mMenu mImg currentVertexRef compTreeRef nextRef - -advance :: Advance -> UI.Element -> UI.Element -> Maybe UI.Element -> Maybe (UI.Element,IORef Int) - -> IORef UID -> IORef CompTree -> IORef Next -> UI () -advance adv status compStmt mMenu mImg currentVertexRef compTreeRef nextRef = do - mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - next <- UI.liftIO $ readIORef nextRef - case mv of - Nothing -> do - t <- UI.liftIO $ readIORef compTreeRef - case next t getJudgement of - RootVertex -> return () -- when does this happen ... ? - w -> advanceTo w status compStmt mMenu mImg currentVertexRef compTreeRef - (Just v) -> do - t <- UI.liftIO $ readIORef compTreeRef - case (adv, next t getJudgement) of - (DoNotAdvance,_) -> advanceTo v status compStmt mMenu mImg currentVertexRef compTreeRef - (AdvanceToNext,RootVertex) -> advanceTo v status compStmt mMenu mImg currentVertexRef compTreeRef - (AdvanceToNext,w) -> advanceTo w status compStmt mMenu mImg currentVertexRef compTreeRef - updateStatus status compTreeRef - -advanceTo w status compStmt mMenu mImg currentVertexRef compTreeRef = do - UI.liftIO $ writeIORef currentVertexRef (vertexUID w) - showStmt compStmt compTreeRef currentVertexRef - case mMenu of Nothing -> return () - (Just menu) -> updateMenu menu compTreeRef currentVertexRef - case mImg of Nothing -> return () - (Just (img,imgCountRef)) -> redraw img imgCountRef compTreeRef (Just w) - - --------------------------------------------------------------------------------- --- Explore the computation tree - -guiExplore :: IORef CompTree -> IORef Int -> IORef String -> IORef Int -> UI UI.Element -guiExplore compTreeRef currentVertexRef regexRef imgCountRef = do - - -- Get a list of vertices from the computation graph - tree <- UI.liftIO $ readIORef compTreeRef - - -- Draw the computation graph - img <- UI.img - redrawWith img imgCountRef compTreeRef currentVertexRef - img' <- UI.center #+ [UI.element img] - - -- Field to show computation statement(s) of current vertex - compStmt <- UI.pre - - -- Menu to select which statement to show - menu <- UI.select # set UI.style [("margin-right","1em")] - showStmt compStmt compTreeRef currentVertexRef - updateMenu menu compTreeRef currentVertexRef - let selectVertex' = selectVertex compStmt menu compTreeRef currentVertexRef (redrawWith img imgCountRef compTreeRef) - on UI.selectionChange menu selectVertex' - - -- Status - status <- UI.span - updateStatus status compTreeRef - - -- Buttons to judge the current statement - right <- UI.button # UI.set UI.text "right " #+ [UI.img # set UI.src "static/right.png" # set UI.height 20] # set UI.style [("margin-right","1em")] - wrong <- UI.button # set UI.text "wrong " #+ [UI.img # set UI.src "static/wrong.png" # set UI.height 20] # set UI.style [("margin-right","1em")] - - nextRef <- UI.liftIO $ newIORef (next_step :: Next) - let j = judge DoNotAdvance status compStmt (Just menu) (Just (img, imgCountRef)) currentVertexRef compTreeRef nextRef - j right Right - j wrong Wrong - - -- Store and restore buttons - storeb <- UI.button # UI.set UI.text "store" # set UI.style [("margin-right","1em")] - restoreb <- UI.button # UI.set UI.text "restore" - on UI.click storeb $ \_ -> UI.liftIO $ store compTreeRef - on UI.click restoreb $ \_ -> do UI.liftIO $ restore compTreeRef - updateStatus status compTreeRef - v <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - redraw img imgCountRef compTreeRef v - - -- Populate the main screen - hr <- UI.hr - br <- UI.br - UI.div #+ (map UI.element [menu, right, wrong, storeb, restoreb, br, hr, img', br, status, hr, compStmt]) - -judgementFilePath :: FilePath -judgementFilePath = ".Hoed/savedJudgements" - -store :: IORef CompTree -> IO () -store compTreeRef = do - t <- readIORef compTreeRef - storeJudgements judgementFilePath t - -restore :: IORef CompTree -> IO () -restore compTreeRef = do - t <- readIORef compTreeRef - t' <- restoreJudgements judgementFilePath t - writeIORef compTreeRef t' - -preorder :: CompTree -> [Vertex] -preorder = getPreorder . getDfs - -showStmt :: UI.Element -> IORef CompTree -> IORef Int -> UI () -showStmt e compTreeRef currentVertexRef = do - mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - let s = case mv of - Nothing -> "No computation statement selected." - (Just v) -> let s = show . vertexStmt $ v in case getJudgement v of - (Assisted s') -> "Results from testing computation statement:\n" ++ (getMessage s') ++ "\n---\n\n" ++ s - _ -> s - UI.element e # set UI.text s - return () - -getMessage :: [AssistedMessage] -> String -getMessage = foldl (\acc m -> acc ++ getMessage' m) "" -getMessage' (InconclusiveProperty msg) = msg -getMessage' (PassingProperty msg) = msg ++ " holds for this statement's values" - --- populate the exploration menu with the current vertex, its predecessor and its successors -updateMenu :: UI.Element -> IORef CompTree -> IORef Int -> UI () -updateMenu menu compTreeRef currentVertexRef = do - vs <- menuVertices compTreeRef currentVertexRef - i <- UI.liftIO $ readIORef currentVertexRef - let j = case findIndex (\v -> vertexUID v == i) vs of - (Just j') -> j' - Nothing -> 0 - t <- UI.liftIO $ readIORef compTreeRef - let fs = faultyVertices t - ops <- mapM (\s->UI.option # set UI.text s) $ map (summarizeVertex fs) vs - (UI.element menu) # set UI.children [] - UI.element menu #+ (map UI.element ops) - (UI.element menu) # set UI.selection (Just j) - return () - --- on selecting a vertex in the exploration menu, update current vertex accordingly -selectVertex :: UI.Element -> UI.Element -> IORef CompTree -> IORef Int - -> (IORef Int -> UI ()) -> Maybe Int -> UI () -selectVertex compStmt menu compTreeRef currentVertexRef myRedraw mi = case mi of - Just j -> do vs <- menuVertices compTreeRef currentVertexRef - mcv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - let v = vs !! j - UI.liftIO $ writeIORef currentVertexRef (vertexUID v) - showStmt compStmt compTreeRef currentVertexRef - myRedraw currentVertexRef - updateMenu menu compTreeRef currentVertexRef - return () - Nothing -> do UI.liftIO $ putStrLn "selectVertex: Nothing selected" - return () - -menuVertices :: IORef CompTree -> IORef Int -> UI [Vertex] -menuVertices compTreeRef currentVertexRef = do - t <- UI.liftIO $ readIORef compTreeRef - i <- UI.liftIO $ readIORef currentVertexRef - mcv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - let cv = case mcv of (Just v) -> v; Nothing -> RootVertex - ps = preds t cv - sibl = if RootVertex `elem` ps then succs t RootVertex else [cv] - return $ filter (/= RootVertex) $ ps ++ sibl ++ (succs t cv) - -lookupCurrentVertex :: IORef Int -> IORef CompTree -> IO (Maybe Vertex) -lookupCurrentVertex currentVertexRef compTree = do - i <- readIORef currentVertexRef - t <- readIORef compTree - return $ case filter (\v->vertexUID v==i) (vertices t) of - [] -> Nothing - [v] -> Just v - vs -> error $ "lookupCurrentVertex: UID " ++ show i ++ " identifies " - ++ (show . length $ vs) ++ " computation statements" - -markNode :: CompTree -> Vertex -> Judgement -> CompTree -markNode g v s = mapGraph f g - where f RootVertex = RootVertex - f v' = if v' === v then setJudgement v s else v' - - (===) :: Vertex -> Vertex -> Bool - v1 === v2 = (vertexUID v1) == (vertexUID v2) - -data MaxStringLength = ShorterThan Int | Unlimited - -shorten :: MaxStringLength -> String -> String -shorten Unlimited s = s -shorten (ShorterThan l) s - | length s < l = s - | l > 3 = take (l - 3) s ++ "..." - | otherwise = take l s - -shorterThan60 = shorten (ShorterThan 60) - -summarizeVertex :: [Vertex] -> Vertex -> String -summarizeVertex fs v = shorterThan60 (noNewlines . show . vertexStmt $ v) ++ s - where s = if v `elem` fs then " !!" else case getJudgement v of - Wrong -> " :(" - Right -> " :)" - _ -> " ??" - -vertexGraphvizLabel :: [Vertex] -> Vertex -> String -vertexGraphvizLabel fs v = - "<
" ++ (htmlEscape . shorterThan60 . noNewlines . show . vertexStmt $ v) ++ "
>" - -htmlEscape :: String -> String -htmlEscape = foldr (\c acc -> replace c ++ acc) "" - where - replace :: Char -> String - replace '"' = """ - replace '{' = "{" - replace '\\' = "\" - replace '>' = ">" - replace '<' = "<" - replace '}' = "}" - replace c = [c] - -vertexImg :: [Vertex] -> Vertex -> String -vertexImg fs v = if v `elem` fs then ".Hoed/wwwroot/faulty.png" else case vertexJmt v of - Unassessed -> ".Hoed/wwwroot/unassessed.png" - (Assisted _) -> ".Hoed/wwwroot/unassessed.png" - Wrong -> ".Hoed/wwwroot/wrong.png" - Right -> ".Hoed/wwwroot/right.png" - - -updateStatus :: UI.Element -> IORef CompTree -> UI () -updateStatus e compGraphRef = do - g <- UI.liftIO $ readIORef compGraphRef - let isJudged v = case getJudgement v of - Right -> True - Wrong -> True - _ -> False -- Assisted does not count as judged - slen = show . length - ns = filter (not . isRootVertex) (preorder g) - js = filter isJudged ns - fs = faultyVertices g - txt = if length fs > 0 then " Fault detected in: " ++ (vertexRes . head) fs - else " Judged " ++ slen js ++ "/" ++ slen ns - UI.element e # set UI.text txt - return () - - -redrawWith :: UI.Element -> IORef Int -> IORef CompTree -> IORef Int -> UI () -redrawWith img imgCountRef compTreeRef currentVertexRef = do - mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef - redraw img imgCountRef compTreeRef mv - -redraw :: UI.Element -> IORef Int -> IORef CompTree -> (Maybe Vertex) -> UI () -redraw img imgCountRef compTreeRef mcv - = do tree <- UI.liftIO $ readIORef compTreeRef - UI.liftIO $ writeFile ".Hoed/debugTree.dot" $ shw (faultyVertices tree) (summarize tree mcv) - UI.liftIO $ system $ "cat .Hoed/debugTree.dot | unflatten -l 5| dot -Tpng -Gsize=15,15 -Gdpi=100" - ++ "> .Hoed/wwwroot/debugTree.png" - i <- UI.liftIO $ readIORef imgCountRef - UI.liftIO $ writeIORef imgCountRef (i+1) - -- Attach counter to image url to reload image - UI.element img # set UI.src ("static/debugTree.png#" ++ show i) - return () - - where shw fs t = showWith t (coloVertex $ fs) showArc - coloVertex _ RootVertex = ("\".\"", "shape=none") - coloVertex fs v = ( vertexGraphvizLabel fs v - , if isCurrentVertex mcv v then "shape=none fontcolor=blue" - else "shape=none" - ) - showArc _ = "" - --- Selects current vertex, its predecessor and its successors -summarize :: CompTree -> Maybe Vertex -> CompTree -summarize tree (Just cv) = Graph r vs as' - where - i = vertexUID cv - ps = preds tree cv - ps' = if RootVertex `elem` ps then ps ++ (succs tree RootVertex) else ps - cs = succs tree cv - vs = nub (ps' ++ cv : cs) - as = filter (\a -> isCV (source a) || isCV (target a)) (arcs tree) - as' = if RootVertex `elem` ps then nub (as ++ filter (\a -> isRV (source a) || isRV (target a)) (arcs tree)) else as - r = if RootVertex `elem` vs then RootVertex else head vs - isCV = (==i) . vertexUID - isRV = (==) RootVertex -summarize tree Nothing = tree - -isCurrentVertex :: Maybe Vertex -> Vertex -> Bool -isCurrentVertex mcv v = case v of - RootVertex -> False - _ -> case mcv of - Nothing -> False - (Just RootVertex) -> False - (Just w) -> vertexStmt v == vertexStmt w - -faultyVertices :: CompTree -> [Vertex] -faultyVertices = findFaulty_dag getJudgement diff --git a/Debug/Hoed/Pure/EventForest.hs b/Debug/Hoed/Pure/EventForest.hs deleted file mode 100644 --- a/Debug/Hoed/Pure/EventForest.hs +++ /dev/null @@ -1,147 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon, 2015 - -module Debug.Hoed.Pure.EventForest -( EventForest(..) -, mkEventForest -, parentUIDLookup -, parentPosLookup - -, InfixOrPrefix(..) -, Location(..) -, Visit -, dfsFold -, idVisit - -, treeUIDs -, topLevelApps -, eventsInTree -, dfsChildren -, elems -) where -import Debug.Hoed.Pure.Observe -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap - --- Searchable mapping from UID of the parent and position in list of siblings --- to a child event. --- type EventForest = [(UID, [(ParentPosition, Event)])] -type EventForest = IntMap [(ParentPosition, Event)] - -isRoot :: Event -> Bool -isRoot e = case change e of Observe{} -> True; _ -> False - -elems :: EventForest -> [[(ParentPosition, Event)]] -elems = IntMap.elems - -addEvent :: EventForest -> Event -> EventForest -addEvent frt e - | isRoot e = frt - | otherwise = IntMap.insert i s frt - where i = parentUID . eventParent $ e - p = parentPosition . eventParent $ e - ms = IntMap.lookup i frt - s = case ms of Nothing -> [(p,e)] - (Just s') -> (p,e) : s' - - -mkEventForest :: Trace -> EventForest -mkEventForest trc = foldl addEvent IntMap.empty trc - -parentUIDLookup :: UID -> EventForest -> [(ParentPosition,Event)] -parentUIDLookup i frt = case IntMap.lookup i frt of - Nothing -> [] - (Just es) -> es - -parentPosLookup :: ParentPosition -> [(ParentPosition,Event)] -> [Event] -parentPosLookup p = map snd . filter ((==p) . fst) - -data InfixOrPrefix = Infix | Prefix - -data Location = Trunk | ArgumentOf Location | ResultOf Location | FieldOf Int Location - deriving Eq - -instance Show Location where - show Trunk = "" - show (ArgumentOf loc) = 'a' : show loc - show (ResultOf loc) = 'r' : show loc - show (FieldOf n loc) = 'f' : show n ++ show loc - -type Visit a = Maybe Event -> Location -> a -> a - -idVisit :: Visit a -idVisit _ _ z = z - --- Given an event, return the list of (expected) children in depth-first order. --- --- Nothing indicates that we expect an event (e.g. the argument of an application- --- event) but it was not there. --- --- An abstraction (LamEvent) can have more than one application. There is no --- particular ordering and we just return the applications (AppEvents) in the --- order we find them in the trace (i.e. evaluation order). - -dfsChildren :: EventForest -> Event -> [Maybe Event] -dfsChildren frt e = case change e of - Enter{} -> manyByPosition 0 -- Should be Nothing? - (Cons l _) -> foldl (\acc x -> acc ++ manyByPosition x) [] [0..(l-1)] - Observe{} -> manyByPosition 0 - Fun -> manyByPosition 0 ++ manyByPosition 1 - - where manyByPosition :: ParentPosition -> [Maybe Event] - manyByPosition pos = case filter (\(pos',_) -> pos == pos') cs of - [] -> [Nothing] - ts -> map (Just . snd) ts - - -- Events in the frt that list our event as parent (in no particular order). - cs :: [(ParentPosition,Event)] - cs = parentUIDLookup (eventUID e) frt - - -dfsFold :: InfixOrPrefix -> Visit a -> Visit a -> a - -> Location -> (Maybe Event) -> EventForest -> a - -dfsFold ip pre post z loc me frt - = post me loc $ case me of - Nothing -> z' - (Just e) -> case change e of - - Fun -> let [arg,res] = cs - in case ip of - Prefix -> csFold $ zip cs [ArgumentOf loc,ArgumentOf loc,ResultOf loc,ResultOf loc] - - Infix -> let z1 = dfsFold ip pre post z (ArgumentOf loc) arg frt - z2 = pre me loc z1 - in dfsFold ip pre post z2 (ResultOf loc) res frt - - Cons{} -> csFold $ zip cs $ map (\i -> FieldOf i loc) [1..] - - _ -> csFold $ zip cs (repeat loc) - - where z' = pre me loc z - - cs :: [Maybe Event] - cs = case me of (Just e) -> dfsChildren frt e; Nothing -> error "dfsFold filter failed" - - csFold = foldl (\z'' (c,loc') -> dfsFold ip pre post z'' loc' c frt) z' - -treeUIDs :: EventForest -> Event -> [UID] -treeUIDs frt = (map eventUID) . eventsInTree frt - --- Given an event r, return depth first ordered list of events in the (sub)tree starting from r. -eventsInTree :: EventForest -> Event -> [Event] -eventsInTree frt r = reverse $ dfsFold Prefix add idVisit [] Trunk (Just r) frt - where add (Just e) _ es = e : es - add Nothing _ es = es - --- Find all toplevel AppEvents for RootEvent r -topLevelApps :: EventForest -> Event -> [Event] -topLevelApps frt r = foldl appendApp [] $ dfsChildren frt r - -appendApp :: [Event] -> Maybe Event -> [Event] -appendApp z me = case me of - Nothing -> z - (Just e) -> case change e of Fun -> e : z - _ -> z - diff --git a/Debug/Hoed/Pure/Observe.lhs b/Debug/Hoed/Pure/Observe.lhs deleted file mode 100644 --- a/Debug/Hoed/Pure/Observe.lhs +++ /dev/null @@ -1,1215 +0,0 @@ -\begin{code} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE CPP #-} - -\end{code} - -The file is part of the Haskell Object Observation Debugger, -(HOOD) March 2010 release. - -HOOD is a small post-mortem debugger for the lazy functional -language Haskell. It is based on the concept of observation of -intermediate data structures, rather than the more traditional -stepping and variable examination paradigm used by imperative -language debuggers. - -Copyright (c) Andy Gill, 1992-2000 -Copyright (c) The University of Kansas 2010 -Copyright (c) Maarten Faddegon, 2013-2015 - -All rights reserved. HOOD is distributed as free software under -the license in the file "License", which available from the HOOD -web page, http://www.haskell.org/hood - -This module produces CDS's, based on the observation made on Haskell -objects, including base types, constructors and functions. - -WARNING: unrestricted use of unsafePerformIO below. - -This was ported for the version found on www.haskell.org/hood. - - -%************************************************************************ -%* * -\subsection{Exports} -%* * -%************************************************************************ - -\begin{code} -module Debug.Hoed.Pure.Observe -{- - ( - -- * The main Hood API - - observeTempl - , observe - , observeCC - , Observer(..) -- contains a 'forall' typed observe (if supported). - -- , Observing -- a -> a - , Observable(..) -- Class - - -- * For advanced users, that want to render their own datatypes. - , (<<) -- (Observable a) => ObserverM (a -> b) -> a -> ObserverM b - , thunk -- (Observable a) => a -> ObserverM a - , nothunk - , send - , observeBase - , observeOpaque - , observedTypes - , Generic - , Trace - , Event(..) - , Change(..) - , Parent(..) - , UID - , ParentPosition - , ThreadId(..) - , isRootEvent - , initUniq - , startEventStream - , endEventStream - , ourCatchAllIO - , peepUniq - ) -} where -\end{code} - - -%************************************************************************ -%* * -\subsection{Imports and infixing} -%* * -%************************************************************************ - -\begin{code} -import Prelude hiding (Right) -import qualified Prelude -import System.IO -import Data.Maybe -import Control.Monad -import Data.Array as Array -import Data.List -import Data.Char -import System.Environment - -import Language.Haskell.TH -import GHC.Generics - -import Data.IORef -import System.IO.Unsafe - -import Control.Concurrent(takeMVar,putMVar,MVar,newMVar) -import qualified Control.Concurrent as Concurrent -\end{code} - -For the TracedMonad instance of IO: -\begin{code} -import GHC.Base hiding (mapM) -\end{code} - -\begin{code} -import qualified Control.Exception as Exception -import Control.Exception (Exception, throw, ErrorCall(..), SomeException(..)) -{- - ( catch - , Exception(..) - , throw - ) as Exception --} -import Data.Dynamic ( Dynamic ) - -\end{code} - -\begin{code} -infixl 9 << -\end{code} - - -%************************************************************************ -%* * -\subsection{GDM Generics} -%* * -%************************************************************************ - -he generic implementation of the observer function. - -\begin{code} -class Observable a where - observer :: a -> Parent -> a - default observer :: (Generic a, GObservable (Rep a)) => a -> Parent -> a - observer x c = to (gdmobserver (from x) c) - - constrain :: a -> a -> a - default constrain :: (Generic a, GConstrain (Rep a)) => a -> a -> a - constrain x c = to (gconstrain (from x) (from c)) - -class GObservable f where - gdmobserver :: f a -> Parent -> f a - gdmObserveArgs :: f a -> ObserverM (f a) - gdmShallowShow :: f a -> String - -constrainBase :: Eq a => a -> a -> a -constrainBase x c | x == c = x -\end{code} - -A type generic definition of constrain - -\begin{code} -class GConstrain f where gconstrain :: f a -> f a -> f a -instance (GConstrain a, GConstrain b) => GConstrain (a :+: b) where - gconstrain (L1 x) (L1 c) = L1 (gconstrain x c) - gconstrain (R1 x) (R1 c) = R1 (gconstrain x c) -instance (GConstrain a, GConstrain b) => GConstrain (a :*: b) where - gconstrain (x :*: y) (c :*: d) = (gconstrain x c) :*: (gconstrain y d) -instance GConstrain U1 where - gconstrain x c = x -instance (Observable a) => GConstrain (K1 i a) where - gconstrain (K1 x) (K1 c) = K1 (constrain x c) -instance (GConstrain a) => GConstrain (M1 D d a) where - gconstrain (M1 x) (M1 c) = M1 (gconstrain x c) -instance (GConstrain a, Selector s) => GConstrain (M1 S s a) where - gconstrain m@(M1 x) n@(M1 c) | selName m == selName n = M1 (gconstrain x c) -instance (GConstrain a, Constructor c) => GConstrain (M1 C c a) where - gconstrain m@(M1 x) n@(M1 c) | conName m == conName n = M1 (gconstrain x c) -\end{code} - -Observing the children of Data types of kind *. - -\begin{code} - --- Meta: data types -instance (GObservable a) => GObservable (M1 D d a) where - gdmobserver m@(M1 x) cxt = M1 (gdmobserver x cxt) - gdmObserveArgs = gthunk - gdmShallowShow = error "gdmShallowShow not defined on the <>" - --- Meta: Selectors -instance (GObservable a, Selector s) => GObservable (M1 S s a) where - gdmobserver (M1 x) cxt = M1 (gdmobserver x cxt) - gdmObserveArgs = gthunk - gdmShallowShow = error "gdmShallowShow not defined on the <>" - --- Meta: Constructors -instance (GObservable a, Constructor c) => GObservable (M1 C c a) where - gdmobserver m1 = send (gdmShallowShow m1) (gdmObserveArgs m1) - gdmObserveArgs (M1 x) = do {x' <- gdmObserveArgs x; return (M1 x')} - gdmShallowShow = conName - --- Unit: used for constructors without arguments -instance GObservable U1 where - gdmobserver x _ = x - gdmObserveArgs = return - gdmShallowShow = error "gdmShallowShow not defined on <>" - --- Sums: encode choice between constructors -instance (GObservable a, GObservable b) => GObservable (a :+: b) where - gdmobserver (L1 x) = send (gdmShallowShow x) (gdmObserveArgs $ L1 x) - gdmobserver (R1 x) = send (gdmShallowShow x) (gdmObserveArgs $ R1 x) - gdmShallowShow (L1 x) = gdmShallowShow x - gdmShallowShow (R1 x) = gdmShallowShow x - gdmObserveArgs (L1 x) = do {x' <- gdmObserveArgs x; return (L1 x')} - gdmObserveArgs (R1 x) = do {x' <- gdmObserveArgs x; return (R1 x')} - --- Products: encode multiple arguments to constructors -instance (GObservable a, GObservable b) => GObservable (a :*: b) where - gdmobserver (a :*: b) cxt = (gdmobserver a cxt) :*: (gdmobserver b cxt) - gdmObserveArgs (a :*: b) = do - a' <- gdmObserveArgs a - b' <- gdmObserveArgs b - return (a' :*: b') - gdmShallowShow = error "gdmShallowShow not defined on <>" - --- Constants: additional parameters and recursion of kind * -instance (Observable a) => GObservable (K1 i a) where - gdmobserver (K1 x) cxt = K1 $ observer x cxt - gdmObserveArgs = gthunk - gdmShallowShow = error "gdmShallowShow not defined on <>" - -\end{code} - -Observing functions is done via the ad-hoc mechanism, because -we provide an instance definition the default is ignored for -this type. - -\begin{code} -instance (Observable a,Observable b) => Observable (a -> b) where - observer fn cxt arg = gdmFunObserver cxt fn arg - constrain = error "how to constrain the function type?" -\end{code} - -Observing the children of Data types of kind *->*. - -\begin{code} -gdmFunObserver :: (Observable a,Observable b) => Parent -> (a->b) -> (a->b) -gdmFunObserver cxt fn arg - = sendObserveFnPacket - (do arg' <- thunk observer arg - thunk observer (fn arg') - ) cxt -\end{code} - -%************************************************************************ -%* * -\subsection{Generics} -%* * -%************************************************************************ - -Generate a new observe from generated observers and the gobserve mechanism. -Where gobserve is the 'classic' observe but parametrized. - -\begin{code} -observeTempl :: String -> Q Exp -observeTempl s = do n <- methodName s - let f = return $ VarE n - s' = stringE s - [| (\x-> fst (gobserve $f $s' x)) |] -\end{code} - -Generate class definition and class instances for list of types. - -\begin{code} -observedTypes :: String -> [Q Type] -> Q [Dec] -observedTypes s qt = do cd <- (genClassDef s) - ci <- foldM f [] qt - bi <- foldM g [] baseTypes - fi <- (gfunObserver s) - -- li <- (gListObserver s) MF TODO: should we do away with these? - return (cd ++ ci ++ bi ++ fi) - where f d t = do ds <- (gobservableInstance s t) - return (ds ++ d) - g d t = do ds <- (gobservableBaseInstance s t) - return (ds ++ d) - baseTypes = [[t|Int|], [t|Char|], [t|Float|], [t|Bool|]] - - - -\end{code} - -Generate a class definition from a string - -\begin{code} - -genClassDef :: String -> Q [Dec] -genClassDef s = do cn <- className s - mn <- methodName s - nn <- newName "a" - let a = PlainTV nn - tvb = [a] - vt = varT nn - mt <- [t| $vt -> Parent -> $vt |] - let m = SigD mn mt - cd = ClassD [] cn tvb [] [m] - return [cd] - -className :: String -> Q Name -className s = return $ mkName ("Observable" ++ headToUpper s) - -methodName :: String -> Q Name -methodName s = return $ mkName ("observer" ++ headToUpper s) - -headToUpper (c:cs) = toUpper c : cs - -\end{code} - -\begin{code} -gobserverBase :: Q Name -> Q Type -> Q [Dec] -gobserverBase qn t = do n <- qn - c <- gobserverBaseClause qn - return [FunD n [c]] - -gobserverBaseClause :: Q Name -> Q Clause -gobserverBaseClause qn = clause [] (normalB (varE $ mkName "observeBase")) [] - -gobserverList :: Q Name -> Q [Dec] -gobserverList qn = do n <- qn - cs <-listClauses qn - return [FunD n cs] - - -\end{code} - -The generic implementation of the observer function, special cases -for base types and functions. - -\begin{code} -gobserver :: Q Name -> Q Type -> Q [Dec] -gobserver qn t = do n <- qn - cs <- gobserverClauses qn t - return [FunD n cs] - -gobserverClauses :: Q Name -> Q Type -> Q [Clause] -gobserverClauses n qt = do t <- qt - bs <- getBindings qt - case t of - _ -> do cs <- (getConstructors . getName) qt - mapM (gobserverClause t n bs) cs - -gobserverClause :: Type -> Q Name -> TyVarMap -> Con -> Q Clause -gobserverClause t n bs (y@(NormalC name fields)) - = do { vars <- guniqueVariables (length fields) - ; let evars = map varE vars - pvars = map varP vars - c' = varP (mkName "c") - c = varE (mkName "c") - ; clause [conP name pvars, c'] - ( normalB [| send $(shallowShow y) $(observeChildren n t bs y evars) $c |] - ) [] - } -gobserverClause t n bs (InfixC left name right) - = gobserverClause t n bs (NormalC name (left:[right])) -gobserverClause t n bs y = error ("gobserverClause can't handle " ++ show y) - -listClauses :: Q Name -> Q [Clause] -listClauses n = do l1 <- listClause1 n - l2 <- listClause2 n - return [l1, l2] - --- observer (a:as) = send ":" (return (:) << a << as) -listClause1 :: Q Name -> Q Clause -listClause1 qn - = do { n <- qn - ; let a' = varP (mkName "a") - a = varE (mkName "a") - as' = varP (mkName "as") - as = varE (mkName "as") - c' = varP (mkName "c") - c = varE (mkName "c") - t = [| thunk $(varE n)|] -- MF TODO: or nothunk - name = mkName ":" - ; clause [infixP a' name as', c'] - ( normalB [| send ":" ( compositionM $t - ( compositionM $t - ( return (:) - ) $a - ) $as - ) $c - |] - ) [] - } - --- observer [] = send "[]" (return []) -listClause2 :: Q Name -> Q Clause -listClause2 qn - = do { n <- qn - ; let c' = varP (mkName "c") - c = varE (mkName "c") - ; clause [wildP, c'] - ( normalB [| send "[]" (return []) $c |] - ) [] - } - -\end{code} - -We also need to do some work to also generate the instance declaration -around the observer method. - -\begin{code} -gobservableInstance :: String -> Q Type -> Q [Dec] -gobservableInstance s qt - = do t <- qt - cn <- className s - let ct = conT cn - n <- case t of - (ForallT tvs _ t') -> [t| $ct $(return t') |] - _ -> [t| $ct $qt |] - m <- gobserver (methodName s) qt - c <- case t of - (ForallT _ c' _) -> return c' - _ -> return [] - return [InstanceD (updateContext cn c) n m] - -#if __GLASGOW_HASKELL__ >= 710 -updateContext :: Name -> [Pred] -> [Pred] -updateContext cn ps = map f ps - where f (AppT (ConT n) ts) -- TH<2.10: f (ClassP n ts) - | nameBase n == "Observable" = (AppT (ConT cn) ts) -- ClassP cn ts - | otherwise = (AppT (ConT n) ts) -- ClassP n ts - f p = p -#else -updateContext :: Name -> [Pred] -> [Pred] -updateContext cn ps = map f ps - where f (ClassP n ts) - | nameBase n == "Observable" = ClassP cn ts - | otherwise = ClassP n ts - f p = p -#endif - -gobservableBaseInstance :: String -> Q Type -> Q [Dec] -gobservableBaseInstance s qt - = do t <- qt - cn <- className s - let ct = conT cn - n <- case t of - (ForallT tvs _ t') -> [t| $ct $(return t') |] - _ -> [t| $ct $qt |] - m <- gobserverBase (methodName s) qt - c <- case t of - (ForallT _ c' _) -> return c' - _ -> return [] - return [InstanceD c n m] - -gobservableListInstance :: String -> Q [Dec] -gobservableListInstance s - = do let qt = [t|forall a . [] a |] - t <- qt - cn <- className s - let ct = conT cn - n <- case t of - (ForallT tvs _ t') -> [t| $ct $(return t') |] - _ -> [t| $ct $qt |] - m <- gobserverList (methodName s) - c <- case t of - (ForallT _ c' _) -> return c' - _ -> return [] - return [InstanceD c n m] - --- MF TODO: what do we do with this? --- gListObserver :: String -> Q [Dec] --- gListObserver s --- = do cn <- className s --- let ct = conT cn --- a = VarT (mkName "a") --- a' = return a --- c <- return [ClassP cn a'] --- n <- [t| $ct [$a'] |] --- m <- gobserverList (methodName s) --- return [InstanceD c n m] - - -gobserverFunClause :: Name -> Q Clause -gobserverFunClause n - = do { [f',a'] <- guniqueVariables 2 - ; let vs = [f', mkName "c", a'] - [f, c, a] = map varE vs - pvars = map varP vs - ; clause pvars - (normalB [| sendObserveFnPacket - ( do a' <- thunk $(varE n) $a - thunk $(varE n) ($f a') - ) $c - |] - ) [] - } - -gobserverFun :: Q Name -> Q [Dec] -gobserverFun qn - = do n <- qn - c <- gobserverFunClause n - cs <- return [c] - return [FunD n cs] - -gfunObserver :: String -> Q [Dec] -gfunObserver s - = do cn <- className s - let ct = conT cn - a = VarT (mkName "a") - b = VarT (mkName "b") - f = return $ AppT (AppT ArrowT a) b -#if __GLASGOW_HASKELL__ >= 710 - p <- return $ AppT (ConT cn) a - q <- return $ AppT (ConT cn) b -#else - let a' = return a - b' = return b - p <- return $ ClassP cn a' - q <- return $ ClassP cn b' -#endif - c <- return [p,q] - n <- [t| $ct $f |] - m <- gobserverFun (methodName s) - return [InstanceD c n m] - -\end{code} - -Creating a shallow representation for types of the Data class. - -\begin{code} -shallowShow :: Con -> ExpQ -shallowShow (NormalC name _) - = stringE (case (nameBase name) of "(,)" -> ","; s -> s) -\end{code} - -Observing the children of Data types of kind *. - -Note how we are forced to add the extra 'vars' argument that should -have the same unique name as the corresponding pattern. - -To implement observeChildren we also define a mapM and compositionM function. -To our knowledge there is no existing work that do this in a generic fashion -with Template Haskell. - -\begin{code} - --- MF TODO: the eqType and isObservable' definitions feel a bit "hacky", --- can we do better? -isObservable :: TyVarMap -> Type -> Type -> Q Bool -isObservable bs s t | s `eqType` t = return True -isObservable bs s t = isObservable' bs t - -eqType (ForallT _ _ t1) t2 = t1 `eqType` t2 -eqType (AppT t1 s1) (AppT t2 s2) = (t1 `eqType` t2) && (s1 `eqType` s2) -eqType (VarT _) (VarT _) = True -- dodgy ... -eqType (ConT n1) (ConT n2) = n1 == n2 -eqType _ _ = False - -isObservable' bs (AppT ListT _) = return True - -isObservable' bs (VarT n) = case lookupBinding bs n of - (Just (T t)) -> isObservableT t - (Just (P p)) -> isObservableP p - Nothing -> return False --- isObservable' bs (AppT t _) = isObservable' bs t -isObservable' (n,_) t@(ConT m) = if n == m then return True else isObservableT t -isObservable' bs t = isObservableT t - -isObservableT :: Type -> Q Bool -isObservableT t@(ConT _) = isInstance (mkName "Observable") [t] -isObservableT _ = return False - -isObservableP :: Pred -> Q Bool -#if __GLASGOW_HASKELL__ >= 710 -isObservableP (AppT (ConT n) _) = return $ (nameBase n) == "Observable" -#else -isObservableP (ClassP n _) = return $ (nameBase n) == "Observable" -#endif -isObservableP _ = return False - - -thunkObservable :: Q Name -> TyVarMap -> Type -> Type -> Q Exp -thunkObservable qn bs s t - = do i <- isObservable bs s t - n <- qn - if i then [| thunk $(varE n) |] else [| nothunk |] - -observeChildren :: Q Name -> Type -> TyVarMap -> Con -> [Q Exp] -> Q Exp -observeChildren n t bs = gmapM (thunkObservable n bs t) - -gmapM :: (Type -> Q Exp) -> Con -> [ExpQ] -> ExpQ -gmapM f (NormalC name fields) vars - = m name (reverse fields) (reverse vars) - where m :: Name -> [(Strict,Type)] -> [ExpQ] -> ExpQ - m n _ [] = [| return $(conE n) |] - m n ((_,t):ts) (v:vars) = [| compositionM $(f t) $(m n ts vars) $v |] - - -compositionM :: Monad m => (a -> m b) -> m (b -> c) -> a -> m c -compositionM f g x = do { g' <- g - ; x' <- f x - ; return (g' x') - } -\end{code} - -And we need some helper functions: - -\begin{code} - --- A mapping from typevars to the type they are bound to. - -type TyVarMap = (Name, [(TyVarBndr,TypeOrPred)]) - -data TypeOrPred = T Type | P Pred - - --- MF TODO lookupBinding - -lookupBinding :: TyVarMap -> Name -> Maybe TypeOrPred -lookupBinding (_,[]) _ = Nothing -lookupBinding (r,((b,t):ts)) n - = let m = case b of (PlainTV m ) -> m - (KindedTV m _) ->m - in if (m == n) then Just t else lookupBinding (r,ts) n - --- Given a parametrized type, get a list with typevars and their bindings --- e.g. [(a,Int), (b,Float)] in (MyData a b) Int Float - -getBindings :: Q Type -> Q TyVarMap -getBindings t = do bs <- getBs t - tvs <- (getTvbs . getName) t - pbs <- getPBindings t - n <- getName t - let fromApps = (zip tvs (map T bs)) - fromCxt = (zip tvs (map P pbs)) - return (n, (fromCxt ++ fromApps)) - -getPBindings :: Q Type -> Q [Pred] -getPBindings qt = do t <- qt - case t of (ForallT _ cs _) -> getPBindings' cs - _ -> return [] - -getPBindings' :: [Pred] -> Q [Pred] -getPBindings' [] = return [] -getPBindings' (p:ps) = do pbs <- getPBindings' ps -#if __GLASGOW_HASKELL__ >= 710 - return $ case p of (AppT (ConT n) t) -> p : pbs - _ -> pbs -#else - return $ case p of (ClassP n t) -> p : pbs - _ -> pbs -#endif - --- Given a parametrized type, get a list with its type variables --- e.g. [a,b] in (MyData a b) Int Float - -getTvbs :: Q Name -> Q [TyVarBndr] -getTvbs name = do n <- name - i <- reify n - case i of - TyConI (DataD _ _ tvbs _ _) - -> return tvbs - i - -> error ("getTvbs: can't reify " ++ show i) - --- Given a parametrized type, get a list with the bindings of type variables --- e.g. [Int,Float] in (MyData a b) Int Float - -getBs :: Q Type -> Q [Type] -getBs t = do t' <- t - let t'' = case t' of (ForallT _ _ s) -> s - _ -> t' - return (getBs' t'') - -getBs' :: Type -> [Type] -getBs' (AppT c t) = t : getBs' c -getBs' _ = [] - --- Given a parametrized type, get the name of the type constructor (e.g. Tree in Tree Int) - -getName :: Q Type -> Q Name -getName t = do t' <- t - getName' t' - -getName' :: Type -> Q Name -getName' t = case t of - (ForallT _ _ t'') -> getName' t'' - (AppT t'' _) -> getName' t'' - (ConT name) -> return name - ListT -> return $ mkName "[]" - TupleT _ -> return $ mkName "(,)" - t'' -> error ("getName can't handle " ++ show t'') - --- Given a type, get a list of type variables. - -getTvs :: Q Type -> Q [TyVarBndr] -getTvs t = do {(ForallT tvs _ _) <- t; return tvs } - --- Given a type, get a list of constructors. - -getConstructors :: Q Name -> Q [Con] -getConstructors name = do {n <- name; TyConI (DataD _ _ _ cs _) <- reify n; return cs} - -guniqueVariables :: Int -> Q [Name] -guniqueVariables n = replicateM n (newName "x") - -observableCxt :: [TyVarBndr] -> Q Cxt -observableCxt tvs = return [classpObservable $ map (\v -> (tvname v)) tvs] - -#if __GLASGOW_HASKELL__ >= 710 -classpObservable :: [Type] -> Type -classpObservable = foldl AppT (ConT (mkName "Observable")) -#else -classpObservable :: [Type] -> Pred -classpObservable = ClassP (mkName "Observable") -#endif - -qcontObservable :: Q Type -qcontObservable = return contObservable - -contObservable :: Type -contObservable = ConT (mkName "Observable") - -qtvname :: TyVarBndr -> Q Type -qtvname = return . tvname - -tvname :: TyVarBndr -> Type -tvname (PlainTV name ) = VarT name -tvname (KindedTV name _) = VarT name - -\end{code} - -%************************************************************************ -%* * -\subsection{Instances} -%* * -%************************************************************************ - - The Haskell Base types - -\begin{code} -instance Observable Int where observer = observeBase - constrain = constrainBase -instance Observable Bool where observer = observeBase - constrain = constrainBase -instance Observable Integer where observer = observeBase - constrain = constrainBase -instance Observable Float where observer = observeBase - constrain = constrainBase -instance Observable Double where observer = observeBase - constrain = constrainBase -instance Observable Char where observer = observeBase - constrain = constrainBase -instance Observable () where observer = observeOpaque "()" - constrain = constrainBase - --- utilities for base types. --- The strictness (by using seq) is the same --- as the pattern matching done on other constructors. --- we evalute to WHNF, and not further. - -observeBase :: (Show a) => a -> Parent -> a -observeBase lit cxt = seq lit $ send (show lit) (return lit) cxt - -observeOpaque :: String -> a -> Parent -> a -observeOpaque str val cxt = seq val $ send str (return val) cxt -\end{code} - -The Constructors. - -\begin{code} -instance (Observable a,Observable b) => Observable (a,b) where - observer (a,b) = send "," (return (,) << a << b) - -instance (Observable a,Observable b,Observable c) => Observable (a,b,c) where - observer (a,b,c) = send "," (return (,,) << a << b << c) - -instance (Observable a,Observable b,Observable c,Observable d) - => Observable (a,b,c,d) where - observer (a,b,c,d) = send "," (return (,,,) << a << b << c << d) - -instance (Observable a,Observable b,Observable c,Observable d,Observable e) - => Observable (a,b,c,d,e) where - observer (a,b,c,d,e) = send "," (return (,,,,) << a << b << c << d << e) - -instance (Observable a) => Observable [a] where - observer (a:as) = send ":" (return (:) << a << as) - observer [] = send "[]" (return []) - -instance (Observable a) => Observable (Maybe a) where - observer (Just a) = send "Just" (return Just << a) - observer Nothing = send "Nothing" (return Nothing) - -instance (Observable a,Observable b) => Observable (Either a b) where - observer (Left a) = send "Left" (return Left << a) - observer (Prelude.Right a) = send "Right" (return Prelude.Right << a) -\end{code} - -Arrays. - -\begin{code} -instance (Ix a,Observable a,Observable b) => Observable (Array.Array a b) where - observer arr = send "array" (return Array.array << Array.bounds arr - << Array.assocs arr - ) - constrain = undefined -\end{code} - -IO monad. - -\begin{code} -instance (Observable a) => Observable (IO a) where - observer fn cxt = - do res <- fn - send "" (return return << res) cxt - constrain = undefined -\end{code} - - - -The Exception *datatype* (not exceptions themselves!). - -\begin{code} -instance Observable SomeException where - observer e = send (" " ++ show e) (return e) - constrain = undefined - --- instance Observable ErrorCall where --- observer (ErrorCall a) = send "ErrorCall" (return ErrorCall << a) - - -instance Observable Dynamic where - observer = observeOpaque "" - constrain = undefined -\end{code} - - -%************************************************************************ -%* * -\subsection{Classes and Data Definitions} -%* * -%************************************************************************ - -MF: why/when do we need these types? -\begin{code} -type Observing a = a -> a - -newtype Observer = O (forall a . (Observable a) => String -> a -> a) -\end{code} - - -%************************************************************************ -%* * -\subsection{The ObserveM Monad} -%* * -%************************************************************************ - -The Observer monad, a simple state monad, -for placing numbers on sub-observations. - -\begin{code} -newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) } - -instance Functor ObserverM where - fmap = liftM - -#if __GLASGOW_HASKELL__ >= 710 -instance Applicative ObserverM where - pure = return - (<*>) = ap -#endif - -instance Monad ObserverM where - return a = ObserverM (\ c i -> (a,i)) - fn >>= k = ObserverM (\ c i -> - case runMO fn c i of - (r,i2) -> runMO (k r) c i2 - ) - -thunk :: (a -> Parent -> a) -> a -> ObserverM a -thunk f a = ObserverM $ \ parent port -> - ( observer_ f a (Parent - { parentUID = parent - , parentPosition = port - }) - , port+1 ) - -gthunk :: (GObservable f) => f a -> ObserverM (f a) -gthunk a = ObserverM $ \ parent port -> - ( gdmobserver_ a (Parent - { parentUID = parent - , parentPosition = port - }) - , port+1 ) - -nothunk :: a -> ObserverM a -nothunk a = ObserverM $ \ parent port -> - ( observer__ a (Parent - { parentUID = parent - , parentPosition = port - }) - , port+1 ) - - -(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b --- fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') } -fn << a = gdMapM (thunk observer) fn a - -gdMapM :: (Monad m) - => (a -> m a) -- f - -> m (a -> b) -- data constructor - -> a -- argument - -> m b -- data -gdMapM f c a = do { c' <- c ; a' <- f a ; return (c' a') } - -\end{code} - - -%************************************************************************ -%* * -\subsection{observe and friends} -%* * -%************************************************************************ - -Our principle function and class - -\begin{code} --- | 'observe' observes data structures in flight. --- --- An example of use is --- @ --- map (+1) . observe \"intermeduate\" . map (+2) --- @ --- --- In this example, we observe the value that flows from the producer --- @map (+2)@ to the consumer @map (+1)@. --- --- 'observe' can also observe functions as well a structural values. --- -{-# NOINLINE gobserve #-} -gobserve :: (a->Parent->a) -> String -> a -> (a,Int) -gobserve f name a = generateContext f name a - -{- | -Functions which you suspect of misbehaving are annotated with observe and -should have a cost centre set. The name of the function, the label of the cost -centre and the label given to observe need to be the same. - -Consider the following function: - -@triple x = x + x@ - -This function is annotated as follows: - -> triple y = (observe "triple" (\x -> {# SCC "triple" #} x + x)) y - -To produce computation statements like: - -@triple 3 = 6@ - -To observe a value its type needs to be of class Observable. -We provided instances for many types already. -If you have defined your own type, and want to observe a function -that takes a value of this type as argument or returns a value of this type, -an Observable instance can be derived as follows: - -@ - data MyType = MyNumber Int | MyName String deriving Generic - - instance Observable MyType -@ --} -{-# NOINLINE observe #-} -observe :: (Observable a) => String -> a -> a -observe lbl = fst . (gobserve observer lbl) - -{- This gets called before observer, allowing us to mark - - we are entering a, before we do case analysis on - - our object. - -} - -{-# NOINLINE observer_ #-} -observer_ :: (a -> Parent -> a) -> a -> Parent -> a -observer_ f a context = sendEnterPacket f a context - -gdmobserver_ :: (GObservable f) => f a -> Parent -> f a -gdmobserver_ a context = gsendEnterPacket a context - -{-# NOINLINE observer__ #-} -observer__ :: a -> Parent -> a -observer__ a context = sendNoEnterPacket a context - -\end{code} - -The functions that output the data. All are dirty. - -\begin{code} -unsafeWithUniq :: (Int -> IO a) -> a -unsafeWithUniq fn - = unsafePerformIO $ do { node <- getUniq - ; fn node - } -\end{code} - -\begin{code} -generateContext :: (a->Parent->a) -> String -> a -> (a,Int) -generateContext f {- tti -} label orig = unsafeWithUniq $ \node -> - do sendEvent node (Parent 0 0) (Observe label node) - return (observer_ f orig (Parent - { parentUID = node - , parentPosition = 0 - }) - , node) - -send :: String -> ObserverM a -> Parent -> a -send consLabel fn context = unsafeWithUniq $ \ node -> - do { let (r,portCount) = runMO fn node 0 - ; sendEvent node context (Cons portCount consLabel) - ; return r - } - -sendEnterPacket :: (a -> Parent -> a) -> a -> Parent -> a -sendEnterPacket f r context = unsafeWithUniq $ \ node -> - do { sendEvent node context Enter - ; ourCatchAllIO (evaluate (f r context)) - (handleExc context) - } - -gsendEnterPacket :: (GObservable f) => f a -> Parent -> f a -gsendEnterPacket r context = unsafeWithUniq $ \ node -> - do { sendEvent node context Enter - ; ourCatchAllIO (evaluate (gdmobserver r context)) - (handleExc context) - } - -sendNoEnterPacket :: a -> Parent -> a -sendNoEnterPacket r context = unsafeWithUniq $ \ node -> - do { sendEvent node context NoEnter - ; ourCatchAllIO (evaluate r) - (handleExc context) - } - -evaluate :: a -> IO a -evaluate a = a `seq` return a - -sendObserveFnPacket :: ObserverM a -> Parent -> a -sendObserveFnPacket fn context - = unsafeWithUniq $ \ node -> - do { let (r,_) = runMO fn node 0 - ; sendEvent node context Fun - ; return r - } -\end{code} - - -%************************************************************************ -%* * -\subsection{Event stream} -%* * -%************************************************************************ - -Trival output functions - -\begin{code} -type Trace = [Event] - -data Event = Event - { eventUID :: !UID -- my UID - , eventParent :: !Parent - , change :: !Change - } - deriving (Eq,Generic) - -data Change - = Observe !String !Int - | Cons !Int !String - | Enter - | NoEnter - | Fun - deriving (Eq, Show,Generic) - -type ParentPosition = Int - -data Parent = Parent - { parentUID :: !UID -- my parents UID - , parentPosition :: !ParentPosition -- my branch number (e.g. the field of a data constructor) - } deriving (Eq,Generic) - -instance Show Event where - show e = (show . eventUID $ e) ++ ": " ++ (show . change $ e) ++ " (" ++ (show . eventParent $ e) ++ ")" - -instance Show Parent where - show p = "P " ++ (show . parentUID $ p) ++ " " ++ (show . parentPosition $ p) - -root = Parent 0 0 - -isRootEvent :: Event -> Bool -isRootEvent e = case change e of Observe{} -> True; _ -> False - -startEventStream :: IO () -startEventStream = writeIORef events [] - -endEventStream :: IO Trace -endEventStream = - do { es <- readIORef events - ; writeIORef events badEvents - ; return es - } - -sendEvent :: Int -> Parent -> Change -> IO () -sendEvent nodeId parent change = - do { nodeId `seq` parent `seq` return () - ; change `seq` return () - ; takeMVar sendSem - ; es <- readIORef events - ; let event = Event nodeId parent change - ; writeIORef events (event `seq` (event : es)) - ; putMVar sendSem () - } - --- local -events :: IORef Trace -events = unsafePerformIO $ newIORef badEvents - -badEvents :: Trace -badEvents = error "Bad Event Stream" - --- use as a trivial semiphore -{-# NOINLINE sendSem #-} -sendSem :: MVar () -sendSem = unsafePerformIO $ newMVar () --- end local -\end{code} - - -%************************************************************************ -%* * -\subsection{unique name supply code} -%* * -%************************************************************************ - -Use the single threaded version - -\begin{code} -type UID = Int - -initUniq :: IO () -initUniq = writeIORef uniq 1 - -getUniq :: IO UID -getUniq - = do { takeMVar uniqSem - ; n <- readIORef uniq - ; writeIORef uniq $! (n + 1) - ; putMVar uniqSem () - ; return n - } - -peepUniq :: IO UID -peepUniq = readIORef uniq - --- locals -{-# NOINLINE uniq #-} -uniq :: IORef UID -uniq = unsafePerformIO $ newIORef 1 - -{-# NOINLINE uniqSem #-} -uniqSem :: MVar () -uniqSem = unsafePerformIO $ newMVar () -\end{code} - - - -%************************************************************************ -%* * -\subsection{Global, initualizers, etc} -%* * -%************************************************************************ - --- \begin{code} --- openObserveGlobal :: IO () --- openObserveGlobal = --- do { initUniq --- ; startEventStream --- } --- --- closeObserveGlobal :: IO Trace --- closeObserveGlobal = --- do { evs <- endEventStream --- ; putStrLn "" --- ; return evs --- } --- \end{code} - -%************************************************************************ -%* * -\subsection{Simulations} -%* * -%************************************************************************ - -Here we provide stubs for the functionally that is not supported -by some compilers, and provide some combinators of various flavors. - -\begin{code} -ourCatchAllIO :: IO a -> (SomeException -> IO a) -> IO a -ourCatchAllIO = Exception.catch - -handleExc :: Parent -> SomeException -> IO a --- handleExc context exc = return (send "throw" (return throw << exc) context) -handleExc context exc = return (send (show exc) (return (throw exc)) context) -\end{code} - -%************************************************************************ diff --git a/Debug/Hoed/Pure/Prop.hs b/Debug/Hoed/Pure/Prop.hs deleted file mode 100644 --- a/Debug/Hoed/Pure/Prop.hs +++ /dev/null @@ -1,686 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon 2015-2016 - -{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances, StandaloneDeriving, CPP, DeriveGeneric #-} - -module Debug.Hoed.Pure.Prop where --- ( judge --- , Propositions(..) --- ) where -import Debug.Hoed.Pure.Observe(Observable(..),Trace(..),UID,Event(..),Change(..),ourCatchAllIO,evaluate,eventParent,parentPosition) -import Debug.Hoed.Pure.Render(CompStmt(..),noNewlines) -import Debug.Hoed.Pure.CompTree(CompTree,Vertex(..),Graph(..),vertexUID,vertexRes,replaceVertex,getJudgement,setJudgement) -import Debug.Hoed.Pure.EventForest(EventForest,mkEventForest,dfsChildren) -import Debug.Hoed.Pure.Serialize -import qualified Data.IntMap as M -import Prelude hiding (Right) -import Data.Graph.Libgraph(Judgement(..),AssistedMessage(..),mapGraph) -import System.Directory(createDirectoryIfMissing) -import System.Process(system) -import System.Exit(ExitCode(..)) -import System.IO(hPutStrLn,stderr) -import System.IO.Unsafe(unsafePerformIO) -import Data.Char(isAlpha) -import Data.Maybe(isNothing,fromJust,isJust) -import Data.List(intersperse,isInfixOf,foldl1) -import GHC.Generics hiding (moduleName) --(Generic(..),Rep(..),from,(:+:)(..),(:*:)(..),U1(..),K1(..),M1(..)) -import Control.Monad(foldM) - ------------------------------------------------------------------------------------------------------------------------- - -data Propositions = Propositions { propositions :: [Proposition] - , propType :: PropType - , funName :: String - , extraModules :: [Module] - } - -data PropType = Specify | PropertiesOf deriving Eq - -data Signature - = Argument Int - | SubjectFunction - | Random - deriving (Show,Eq) - -data TestGen = TestGenQuickCheck | TestGenLegacyQuickCheck -- TestGenSmallCheck - deriving Show - -data Proposition = Proposition { propositionType :: PropositionType - , propModule :: Module - , propName :: String - , signature :: [Signature] - , maxSize :: Maybe Int - , testgen :: TestGen - } deriving Show - -mkProposition :: Module -> String -> Proposition -mkProposition m f = Proposition { propositionType = BoolProposition - , propModule = m - , propName = f - , signature = [SubjectFunction,Argument 0] - , maxSize = Nothing - , testgen = TestGenQuickCheck - } - -ofType :: Proposition -> PropositionType -> Proposition -ofType p t = p{propositionType = t} - -withSignature :: Proposition -> [Signature] -> Proposition -withSignature p s = p{signature = s} - -sizeHint :: Proposition -> Int -> Proposition -sizeHint p n = p{maxSize = Just n} - -withTestGen :: Proposition -> TestGen -> Proposition -withTestGen p f = p{testgen=f} - -data PropositionType - = IOProposition - | BoolProposition - | LegacyQuickCheckProposition - | QuickCheckProposition - deriving Show - -data Module = Module {moduleName :: String, searchPath :: String} - deriving Show - -data PropRes - = Error Proposition String - | Hold Proposition - | HoldWeak Proposition - | Disprove Proposition - | DisproveBy Proposition [String] - deriving Show - ------------------------------------------------------------------------------------------------------------------------- - -sourceFile = ".Hoed/exe/Main.hs" -buildFiles = ".Hoed/exe/Main.o .Hoed/exe/Main.hi" -exeFile = ".Hoed/exe/Main" -outFile = ".Hoed/exe/Main.out" -errFile = ".Hoed/exe/Main.compilerMessages" -treeFilePath = ".Hoed/savedCompTree." -traceFilePath = ".Hoed/savedTrace." - ------------------------------------------------------------------------------------------------------------------------- - -lookupPropositions :: [Propositions] -> Vertex -> Maybe Propositions -lookupPropositions _ RootVertex = Nothing -lookupPropositions ps v = lookupWith funName lbl ps - where lbl = (stmtLabel . vertexStmt) v - -lookupWith :: Eq a => (b->a) -> a -> [b] -> Maybe b -lookupWith f x ys = case filter (\y -> f y == x) ys of - [] -> Nothing - (y:_) -> Just y - ------------------------------------------------------------------------------------------------------------------------- - - -data Judge - = Judge Judgement - -- ^ Returns a Judgement (see Libgraph library). - | AlternativeTree CompTree Trace - -- ^ Found counter example with simpler computation tree. - --- TODO: review this function, not sure if complexity suggestion actually makes sense there... -judgeAll :: UnevalHandler -> (CompTree -> Int) -> Trace -> [Propositions] -> CompTree -> IO CompTree -judgeAll handler complexity trc ps compTree = foldM f compTree (vertices compTree) - where - c = complexity compTree - f :: CompTree -> Vertex -> IO CompTree - f curTree v = do - putStrLn $ take 50 (cycle "-") - putStrLn $ "Evaluating properties to judge statement: " ++ vertexRes v - putStrLn $ take 50 (cycle "-") - case lookupPropositions ps v of - Nothing -> do - putStrLn "*** no propositions" - return curTree - (Just p) -> do - j <- judge' handler trc p v complexity curTree - case j of - (Judge jmt) -> do - putStrLn $ "*** judgement is " ++ show jmt - return $ replaceVertex curTree (setJudgement v jmt) - (AlternativeTree t' _) -> do - let msg = "Simpler tree suggested with complexity " ++ show (complexity t') - ++ "(current tree has complexity of " ++ show c ++ ")" - putStrLn $ "*** " ++ msg - return $ replaceVertex curTree (setJudgement v (Assisted [InconclusiveProperty msg])) - - --- |Use propositions to judge a computation statement. --- First tries restricted and bottom for unevaluated expressions, --- then unrestricted, and finally with randomly generated values --- for unevaluated expressions. -judge :: Trace -> Propositions -> Vertex -> (CompTree -> Int) -> CompTree -> IO Judge -judge trc p v complexity curTree = do - putStrLn $ take 50 (cycle "-") - putStrLn $ "Evaluating properties to judge statement: " ++ vertexRes v - putStrLn $ take 50 (cycle "-") - putStrLn "### ATTEMPT 1: with a restricted subject function\n" - res1 <- judge' RestrictedBottom trc p v complexity curTree - case res1 of - (Judge (Assisted _)) -> do - putStrLn "### ATTEMPT 2: with an unrestricted subject function\n" - res2 <- judge' Bottom trc p v complexity curTree - case res2 of - (Judge (Assisted _)) -> do - putStrLn "### ATTEMPT 3: with randomly generated values\n" - judge' Forall trc p v complexity curTree - _ -> return res2 - (Judge _) -> return res1 - return res1 - -judge' RestrictedBottom trc p v complexity curTree = do - pas <- evalPropositions RestrictedBottom trc p v - let j | propType p == Specify && all holds pas = (Judge Right) - | any disproves pas = (Judge Wrong) - | otherwise = advice pas - return j - -judge' handler trc p v complexity curTree = do - pas <- evalPropositions handler trc p v - let j | propType p == Specify && all holds pas = return (Judge Right) - | any disproves pas = do - let curComplexity = complexity curTree - (bestComplexity,bestTree,bestTrace) <- simplestTree complexity (extraModules p) pas (curComplexity,curTree,[]) trc v - if bestComplexity == curComplexity - then return $ Judge $ Assisted $ [InconclusiveProperty $ "We found values for the unevaluated " - ++ "expressions in the current statement that falsify\n" - ++ "a property, however the resulting tree is not simpler."] - else return (AlternativeTree bestTree bestTrace) - | otherwise = return (advice pas) - j - -holds :: PropRes -> Bool -holds (Hold _) = True -holds (HoldWeak _) = True -holds _ = False - -disproves :: PropRes -> Bool -disproves (Disprove _) = True -disproves (DisproveBy _ _) = True -disproves _ = False - -disprovesBy :: PropRes -> Bool -disprovesBy (DisproveBy _ _) = True -disprovesBy _ = False - --- Using the given complexity function, compare the computation trees of the list of --- property results and select the simplest tree. -simplestTree :: (CompTree -> Int) -> [Module] -> [PropRes] -> (Int,CompTree,Trace) -> Trace -> Vertex -> IO (Int,CompTree,Trace) -simplestTree complexity ms rs cur trc v = foldM (simple2 complexity trc v ms) cur (filter disproves rs) - --- Using the given complexity function, read the computation tree of the given property --- into memory and compare its complexity with the complexity of the currently best tree. --- Return whichever of these two trees is simplest. -simple2 :: (CompTree -> Int) -> Trace -> Vertex -> [Module] -> (Int,CompTree,Trace) -> PropRes -> IO (Int,CompTree,Trace) -simple2 complexity trc v ms (curComplexity,curTree,curTrace) propRes = do - reEvalProposition propRes trc v ms - maybeCandTree <- restoreTree $ treeFilePath ++ resOf propRes - maybeCandTrace <- restoreTrace $ traceFilePath ++ resOf propRes - case (maybeCandTree,maybeCandTrace) of - (Just candTree, Just candTrace) -> do - let candComplexity = complexity candTree - putStrLn $ "Discovered new tree with complexity " ++ show candComplexity - ++ " (current tree is " ++ show curComplexity ++ ")" - return $ if candComplexity < curComplexity - then (candComplexity,candTree,candTrace) - else (curComplexity,curTree,curTrace) - _ -> do - putStrLn $ "FAILED to to restore computation tree of " ++ resOf propRes - return (curComplexity,curTree,curTrace) - -advice :: [PropRes] -> Judge -advice rs' = case filter holds rs' of - [] -> Judge $ Assisted $ errorMessages rs' - rs -> Judge $ Assisted $ PassingProperty (commas (map resOf rs)) : errorMessages rs' - -commas :: [String] -> String -commas = concat . (intersperse ", ") - -errorMessages :: [PropRes] -> [AssistedMessage] -errorMessages = foldl (\acc (Error prop msg) -> InconclusiveProperty ("\n---\n\nApplying property " ++ propName prop ++ " gives inconclusive result:\n\n" ++ msg) : acc) [] . filter isError - -isError (Error _ _) = True -isError _ = False - -data UnevalHandler = RestrictedBottom | Bottom | Forall | FromList [String] deriving (Eq, Show) - -unevalHandler :: UnevalHandler -> PropVarGen String -unevalHandler RestrictedBottom = propVarError -unevalHandler Bottom = propVarError -unevalHandler Forall = propVarFresh -unevalHandler (FromList _) = propVarFresh - -unevalState :: UnevalHandler -> PropVars -unevalState RestrictedBottom = propVars0 -unevalState Bottom = propVars0 -unevalState Forall = propVars0 --- unevalState (FromList _) = propVars0 --- Replace last line with -unevalState (FromList values) = ([],values) --- to directly substitute unevaluated expressions with the FromList values. --- This is only valid when all randomly generated values are actually substituting --- unevaluated expressions (this is not always the case, consider e.g. testing f in --- quickCheck p where p f x y = f x == g x y) - -resOf :: PropRes -> String -resOf (Error p _) = propName p -resOf (Hold p) = propName p -resOf (HoldWeak p) = propName p -resOf (Disprove p) = propName p -resOf (DisproveBy p _) = propName p - -evalPropositions :: UnevalHandler -> Trace -> Propositions -> Vertex -> IO [PropRes] -evalPropositions _ _ _ RootVertex = return [] -evalPropositions handler trc p v = mapM (evalProposition handler trc v (extraModules p)) (propositions p) - -evalProposition :: UnevalHandler -> Trace -> Vertex -> [Module] -> Proposition -> IO PropRes -evalProposition RestrictedBottom trc v ms prop | not (SubjectFunction `elem` (signature prop)) = do - putStrLn $ "property " ++ propName prop ++ ": Cannot restrict subject function!" - return $ Error prop "Cannot restrict subject function!" -evalProposition handler trc v ms prop = do - putStrLn $ "property " ++ propName prop - createDirectoryIfMissing True ".Hoed/exe" - clean - prgm <- generateCode handler trc v prop ms - compile prop - exit <- compile prop - case exit of - (ExitFailure _) -> do - err <- readFile errFile - putStrLn $ "failed to compile: " ++ err - return $ Error prop $ "Compilation of {{{\n" ++ prgm ++ "\n}}} failed with:\n" ++ err - ExitSuccess -> do - exit <- run - out <- readFile outFile - putStrLn $ "evaluated to: " ++ out - return $ mkPropRes prop exit (backspaces out) - - -reEvalProposition :: PropRes -> Trace -> Vertex -> [Module] -> IO PropRes -reEvalProposition (Disprove prop) _ _ _ = return (Disprove prop) -- no need to re-evaluate -reEvalProposition (DisproveBy prop values) trc v ms = do - putStrLn $ "RE-EVALUATE with " ++ concat valuesInBrackets ++ " {" - (Disprove p) <- evalProposition (FromList valuesInBrackets) trc v ms prop - putStrLn $ "} RE-EVALUATE" - return (Disprove p) - where - valuesInBrackets = map (\s -> " (" ++ s ++ ") ") values - -clean = system $ "rm -f " ++ sourceFile ++ " " ++ exeFile ++ " " ++ buildFiles - -compile prop = system $ "ghc -i" ++ (searchPath . propModule) prop ++ " -o " ++ exeFile ++ " " ++ sourceFile ++ " > " ++ errFile ++ " 2>&1" - -run = system $ exeFile ++ " > " ++ outFile ++ " 2>&1" - -generateCode :: UnevalHandler -> Trace -> Vertex -> Proposition -> [Module] -> IO String -generateCode handler trc v prop ms = do - -- Uncomment the next line to dump generated program on screen - -- hPutStrLn stderr $ "Generated the following program ***\n" ++ prgm ++ "\n***" - writeFile sourceFile prgm - return prgm - where - prgm = generate handler prop ms trc (getEventFromMap $ eventMap trc) i f - i = (stmtIdentifier . vertexStmt) v - f = (stmtLabel . vertexStmt) v - - -getEventFromMap m j = fromJust $ M.lookup j m - -eventMap trc = M.fromList $ map (\e -> (eventUID e, e)) trc - -mkPropRes :: Proposition -> ExitCode -> String -> PropRes -mkPropRes prop (ExitFailure _) out = Error prop out -mkPropRes prop ExitSuccess out - | out == "True\n" = Hold prop - | out == "+++ OK, passed 100 tests.\n" = HoldWeak prop - | out == "False\n" = Disprove prop - | "Failed! Falsifiable" `isInfixOf` out = DisproveBy prop (reverse . tail . lines $ out) - | otherwise = Error prop out - -shorten s - | length s < 120 = s - | otherwise = (take 117 s) ++ "..." - -backspaces :: String -> String -backspaces s = reverse (backspaces' [] s) - where - backspaces' s [] = s - backspaces' s (c:t) - | c == '\b' = backspaces' (safeTail s) t - | otherwise = backspaces' (c:s) t - - safeTail [] = [] - safeTail (c:s) = s - ------------------------------------------------------------------------------------------------------------------------- - -type PropVars = ([String],[String]) -- A tuple of used variables, and a supply of fresh variables -type PropVarGen a = PropVars -> (a,PropVars) - -comp :: PropVarGen a -> PropVarGen b -> (a -> b -> c) -> PropVarGen c -comp x y f vs = let (x', vs') = x vs - (y', vs'') = y vs' - in (f x' y', vs'') - --- MF TODO: this is exactly like liftM2 -liftPV :: (a -> b -> c) -> PropVarGen a -> PropVarGen b -> PropVarGen c -liftPV f x y = comp x y f - -propVars0 :: PropVars -propVars0 = ([], map (('x':) . show) [1..]) - -propVarError :: PropVarGen String -propVarError = propVarReturn "(error \"Request of value that was unevaluated in original program.\")" - -propVarFresh :: PropVarGen String -propVarFresh (bvs,v:fvs) = (v, (v:bvs,fvs)) - -propVarReturn :: String -> PropVarGen String -propVarReturn s vs = (s,vs) - -propVarBind :: UnevalHandler -> (String,PropVars) -> Proposition -> String -propVarBind (FromList _) (propApp,_) prop = generatePrint prop ++ propApp -propVarBind _ (propApp,([],_)) prop = generatePrint prop ++ propApp -propVarBind _ (propApp,(bvs,_)) prop = qc ++ " (\\" ++ bvs' ++ " -> " ++ propApp ++ ")" - where - bvs' = concat (intersperse " " bvs) - qc = case (testgen prop, maxSize prop) of - (TestGenQuickCheck, Nothing) - -> "quickCheckWith stdArgs{maxDiscardRatio=50}" - (TestGenQuickCheck, Just n) - -> "quickCheckWith stdArgs{maxDiscardRatio=50,maxSize=" ++ show n ++ "}" - (TestGenLegacyQuickCheck, Nothing) - -> "check defaultConfig{configMaxFail=5000}" - (TestGenLegacyQuickCheck, Just n) - -> "check defaultConfig{configMaxFail=5000,configSize=(+" ++ show n ++ ") . (`div` 2)}" - -generatePrint :: Proposition -> String -generatePrint p = case propositionType p of - IOProposition -> "" - BoolProposition -> "print $ " - QuickCheckProposition -> "(\\q -> do MkRose res ts <- reduceRose . unProp . (\\p->unGen p (mkQCGen 1) 1) . unProperty $ q; print . fromJust . ok $ res) $ " - LegacyQuickCheckProposition -> "do g <- newStdGen; print . fromJust . ok . (generate 1 g) . evaluate $ " - ------------------------------------------------------------------------------------------------------------------------- - -generate :: UnevalHandler -> Proposition -> [Module ] -> Trace -> (UID->Event) -> UID -> String -> String -generate handler prop ms trc getEvent i f = generateHeading prop ms ++ generateMain handler prop trc getEvent i f - -generateHeading :: Proposition -> [Module] -> String -generateHeading prop ms = - "-- This file is generated by the Haskell debugger Hoed\n" - ++ generateImport (propModule prop) - ++ generateImport (Module "qualified Debug.Hoed.Pure as Hoed" []) - ++ qcImports - ++ foldl (\acc m -> acc ++ generateImport m) "" ms - where - qcImports = case propositionType prop of - BoolProposition -> generateImport (Module "Test.QuickCheck" []) - IOProposition -> generateImport (Module "Test.QuickCheck" []) - LegacyQuickCheckProposition -> qcImports' - QuickCheckProposition -> qcImports' - ++ generateImport (Module "Test.QuickCheck.Property" []) - ++ generateImport (Module "Test.QuickCheck.Gen" []) - ++ generateImport (Module "Test.QuickCheck.Random" []) - qcImports' - = generateImport (Module "System.Random" []) -- newStdGen - ++ generateImport (Module "Data.Maybe" []) -- fromJust - ++ generateImport (Module "Test.QuickCheck" []) - -generateImport :: Module -> String -generateImport m = "import " ++ (moduleName m) ++ "\n" - -generateMain :: UnevalHandler -> Proposition -> Trace -> (UID->Event) -> UID -> String -> String -generateMain handler prop trc getEvent i f - = "main = Hoed.runOstore \"" ++ (propName prop) ++"\" $ " - ++ propVarBind handler (foldl accSig ((propName prop) ++ " ",unevalState handler) (signature prop)) prop - -- ++ appValues handler - ++ "\n" - where - -- appValues (FromList values) = concat (map (" "++) values) - -- appValues _ = "" - accSig :: (String,PropVars) -> Signature -> (String,PropVars) - accSig (acc,propVars) x = let (s,propVars') = getSig x propVars in (acc ++ " " ++ s, propVars') - getSig :: Signature -> PropVarGen String - getSig SubjectFunction = cf - getSig (Argument i) | i < length args = args !! i - -- MF TODO: should we do something better when user gives index that is out of bounds? - getSig Random = propVarFresh - getSig _ = propVarError - - args :: [PropVarGen String] - args = generateArgs (unevalHandler handler) trc getEvent i - - cf :: PropVarGen String - cf | handler == RestrictedBottom - = foldl1 (liftPV $ \acc c -> acc ++ " " ++ c) - [ propVarReturn $ "(" ++ genConAp (length args) f - , generateRes (unevalHandler handler) trc getEvent i - , propVarReturn $ ")" - ] - | otherwise = propVarReturn f - -generateRes :: (PropVarGen String) -> Trace -> (UID -> Event) -> UID -> PropVarGen String -generateRes unevalGen trc getEvent i - | areFun mres = (propVarReturn " {- generateRes -} ") `pvCat` - (generateRes unevalGen trc getEvent (eventUID . head . justFuns $ mres)) -- (*) - | otherwise = case mres of [_,mr] -> generateRes' unevalGen trc getEvent mr - -- - -- (*) MF TODO: can there be multiple funs in mres? what then? - -- - where - mres = filter isJustRes children - mr = case mres of [_,e] -> e; _ -> Nothing - children = dfsChildren frt e - frt = (mkEventForest trc) - e = getEvent i - -generateRes' :: PropVarGen String -> Trace -> (UID->Event) -> Maybe Event -> PropVarGen String -generateRes' unevalGen trc getEvent Nothing = unevalGen -generateRes' unevalGen trc getEvent (Just e) - | change e == Fun = - case dfsChildren frt e of - [_,_ ,_,mr] -> - generateRes' unevalGen trc getEvent mr - [Nothing,_,mr] -> - generateRes' unevalGen trc getEvent mr - as -> - error $ "generateRes': event " ++ show (eventUID e) - ++ ":FUN has " ++ show (length as) ++ " children!\nnamely: " ++ commas (map show as) - | otherwise = generateExpr unevalGen trc getEvent frt (Just e) - where - frt = (mkEventForest trc) - -generateArgs :: (PropVarGen String) -> Trace -> (UID -> Event) -> UID -> [PropVarGen String] -generateArgs unevalGen trc getEvent i = - (propVarReturn " {- generateArgs -} ") `pvCat` - pvArg `pvCat` (propVarReturn $ " {- more: " ++ show mres ++ " -} ") - : moreArgs unevalGen trc getEvent mr - where - pvArg | areFun marg = generateFunMap unevalGen trc getEvent (justFuns marg) - | otherwise = case marg of - [Nothing] -> unevalGen - [_,ma] -> generateExpr unevalGen trc getEvent frt ma - e = getEvent i - marg = filter nothingOrArg children - mres = filter isJustRes children - mr = case mres of [_,e] -> e; _ -> Nothing - children = dfsChildren frt e - frt = (mkEventForest trc) - -nothingOrArg Nothing = True -nothingOrArg (Just e) = isArg e - -noArg [Nothing] = True -noArg _ = False - -areFun :: [Maybe Event] -> Bool -areFun (_:e:_) = isJustFun e -areFun _ = False - -justFuns :: [Maybe Event] -> [Event] -justFuns = map fromJust . filter isJustFun - -isJustFun :: Maybe Event -> Bool -isJustFun (Just e) = change e == Fun -isJustFun Nothing = False - -generateFunMap :: (PropVarGen String) -> Trace -> (UID -> Event) -> [Event] -> PropVarGen String -generateFunMap unevalGen trc getEvent funs - | length funs > 0 = caseOf `pvCat` (pvConcat cases') `pvCat` esac - | otherwise = propVarReturn "{- a fun without applications? -}" - where - caseOf = propVarReturn $ " {- funmap with " ++ (show . length $ funs ) ++ " cases -} " - ++ "(\\y -> case y of " - esac = propVarReturn ")" - cases, cases' :: [PropVarGen String] - cases = map (\fun -> generateCase unevalGen trc getEvent fun) funs - cases' = intersperse (propVarReturn "; ") cases - -generateCase :: (PropVarGen String) -> Trace -> (UID -> Event) -> Event -> PropVarGen String -generateCase unevalGen trc getEvent fun = - (propVarReturn $ " {- CASE " ++ show fun ++ " -} ") `pvCat` - case args of - [] -> (propVarReturn "{- catchall -} _") --> res - _ -> (foldl1 (liftPV $ \acc c -> acc ++ " " ++ c) args) --> res - where - args :: [PropVarGen String] - args = map (generateExpr (propVarReturn "_") trc getEvent frt) - . filter (\(Just e) -> isArg e) . filter isJust . dfsChildren frt $ fun - res :: PropVarGen String - res = generateRes unevalGen trc getEvent (eventUID fun) - (-->) :: PropVarGen String -> PropVarGen String -> PropVarGen String - (-->) = liftPV $ \x y -> x ++ " -> " ++ y - frt = mkEventForest trc -- MF TODO: create just once and share? - -isArg = hasParentPos 0 - -isRes = hasParentPos 1 - -isJustRes (Just e) = isRes e -isJustRes Nothing = False - -hasParentPos i = (==i) . parentPosition . eventParent - -pvCat :: PropVarGen String -> PropVarGen String -> PropVarGen String -pvCat = liftPV (++) - -pvConcat :: [PropVarGen String] -> PropVarGen String -pvConcat = foldl pvCat (propVarReturn "") - -moreArgs :: PropVarGen String -> Trace -> (UID->Event) -> Maybe Event -> [PropVarGen String] -moreArgs _ trc getEvent Nothing = [] -moreArgs unevalGen trc getEvent (Just e) - | change e == Fun = generateArgs unevalGen trc getEvent (eventUID e) - | otherwise = [] - -generateExpr :: PropVarGen String -> Trace -> (UID -> Event) -> EventForest -> Maybe Event -> PropVarGen String -generateExpr unevalGen _ _ _ Nothing = unevalGen -generateExpr unevalGen trc getEvent frt (Just e) = - -- (propVarReturn $ "{- generateExpr " ++ show e ++ "-}") `pvCat` - case change e of - (Cons _ s) -> let s' = if isAlpha (head s) then s else "(" ++ s ++ ")" - in liftPV (++) ( foldl (liftPV $ \acc c -> acc ++ " " ++ c) - (propVarReturn ("(" ++ s')) cs - ) - ( propVarReturn ") " - ) - Enter -> propVarReturn "" - -- Fun -> generateFunMap unevalGen trc getEvent (justFuns xs) - evnt -> propVarReturn $ "error \"cannot represent: " ++ show evnt ++ "\"" - - where cs :: [PropVarGen String] - cs = map (generateExpr unevalGen trc getEvent frt) xs - xs = (dfsChildren frt e) - - --- only works if there is 1 argument -conAp :: Observable b => (a -> b) -> b -> a -> b -conAp f r x = constrain (f x) r - -genConAp :: Int -> String -> String -genConAp n f | n > 0 = "(\\r " ++ args ++ " -> Hoed.constrain (" ++ f ++ " " ++ args ++ ") r)" - where args = foldl1 (\a x -> a ++ " " ++ x) xs - xs = map (\i -> "x" ++ show i) [1..n] - --------------------------------------------------------------------------------- --- MF TODO: this should probably be part of the Observable class ... - - -(===) :: ParEq a => a -> a -> Bool -x === y = case parEq x y of (Just b) -> b - Nothing -> error "might be equal" - -class ParEq a where - parEq :: a -> a -> Maybe Bool - default parEq :: (Generic a, GParEq (Rep a)) => a -> a -> Maybe Bool - parEq x y = gParEq (from x) (from y) - -class GParEq rep where - gParEq :: rep a -> rep a -> Maybe Bool - -orNothing :: IO (Maybe Bool) -> Maybe Bool -orNothing mb = unsafePerformIO $ ourCatchAllIO mb (\_ -> return Nothing) - -catchEq :: Eq a => a -> a -> Maybe Bool -catchEq x y = orNothing $ do mb <- evaluate (x == y); return (Just mb) - -catchGEq :: GParEq rep => rep a -> rep a -> Maybe Bool -catchGEq x y = orNothing $ x `seq` y `seq` (evaluate $ gParEq x y) - --- Sums: encode choice between constructors -instance (GParEq a, GParEq b) => GParEq (a :+: b) where - gParEq x y = let r = gParEq_ x y in r - where gParEq_ (L1 x) (L1 y) = x `catchGEq` y - gParEq_ (R1 x) (R1 y) = x `catchGEq` y - gParEq_ _ _ = Just False - --- Products: encode multiple arguments to constructors -instance (GParEq a, GParEq b) => GParEq (a :*: b) where - gParEq x y = let r = gParEq_ x y in r - where gParEq_ (x :*: x') (y :*: y') - | any (== (Just False)) mbs = Just False - | all (== (Just True)) mbs = Just True - | otherwise = Nothing - where mbs = [(catchGEq x y) `seq` (catchGEq x y), (catchGEq x' y') `seq` (catchGEq x' y')] - --- Unit: used for constructors without arguments -instance GParEq U1 where - gParEq x y = let r = gParEq_ x y in r - where gParEq_ x y = catchEq x y - --- Constants: additional parameters and recursion of kind * -instance (ParEq a) => GParEq (K1 i a) where - gParEq x y = let r = gParEq_ x y in r - where gParEq_ (K1 x) (K1 y) = x `parEq` y - --- Meta: data types -instance (GParEq a) => GParEq (M1 D d a) where - gParEq x y = let r = gParEq_ x y in r - where gParEq_ (M1 x) (M1 y) = x `catchGEq` y - --- Meta: Selectors -instance (GParEq a, Selector s) => GParEq (M1 S s a) where - gParEq x y = let r = gParEq_ x y in r - where gParEq_ (M1 x) (M1 y) = x `catchGEq` y - --- Meta: Constructors -instance (GParEq a, Constructor c) => GParEq (M1 C c a) where - gParEq x y = let r = gParEq_ x y in r - where gParEq_ (M1 x) (M1 y) = x `catchGEq` y - -instance (ParEq a) => ParEq [a] -instance (ParEq a, ParEq b) => ParEq (a,b) -instance (ParEq a) => ParEq (Maybe a) -instance ParEq Int where parEq x y = Just (x == y) -instance ParEq Bool where parEq x y = Just (x == y) -instance ParEq Integer where parEq x y = Just (x == y) -instance ParEq Float where parEq x y = Just (x == y) -instance ParEq Double where parEq x y = Just (x == y) -instance ParEq Char where parEq x y = Just (x == y) diff --git a/Debug/Hoed/Pure/Render.hs b/Debug/Hoed/Pure/Render.hs deleted file mode 100644 --- a/Debug/Hoed/Pure/Render.hs +++ /dev/null @@ -1,324 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon, 2014 -{-# LANGUAGE CPP, DeriveGeneric #-} - -module Debug.Hoed.Pure.Render -(CompStmt(..) -,renderCompStmts -,CDS -,eventsToCDS -,rmEntrySet -,simplifyCDSSet -,noNewlines -) where -import Debug.Hoed.Pure.EventForest - -import Text.PrettyPrint.FPretty hiding (sep) -import Prelude hiding(lookup) -import Debug.Hoed.Pure.Observe -import Data.List(sort,sortBy,partition,nub -#if __GLASGOW_HASKELL__ >= 710 - , sortOn -#endif - ) -import Data.Graph.Libgraph -import Data.Array as Array -import Data.Char(isAlpha) -import GHC.Generics - -#if __GLASGOW_HASKELL__ < 710 -sortOn :: Ord b => (a -> b) -> [a] -> [a] -sortOn f = map snd . sortOn' fst . map (\x -> (f x, x)) - -sortOn' :: Ord b => (a -> b) -> [a] -> [a] -sortOn' f = sortBy (\x y -> compare (f x) (f y)) -#endif - ------------------------------------------------------------------------- --- The CompStmt type - --- MF TODO: naming here is a bit of a mess. Needs refactoring. --- Indentifier refers to an identifier users can explicitely give --- to observe'. But UID is the unique number assigned to each event. --- The field equIdentifier is not an Identifier, but the UID of the --- event that starts the observation. And stmtUIDs is the list of --- UIDs of all events that form the statement. - -data CompStmt = CompStmt { stmtLabel :: String - , stmtIdentifier :: UID - , stmtRes :: String - } - deriving (Eq,Ord,Generic) - -instance Show CompStmt where - show = stmtRes - showList eqs eq = unlines (map show eqs) ++ eq - -noNewlines :: String -> String -noNewlines = noNewlines' False -noNewlines' _ [] = [] -noNewlines' w (s:ss) - | w && (s == ' ' || s == '\n') = noNewlines' True ss - | (not w) && (s == ' ' || s == '\n') = ' ' : noNewlines' True ss - | otherwise = s : noNewlines' False ss - ------------------------------------------------------------------------- --- Render equations from CDS set - -statementWidth = 110 -- 110 is good for papers (maybe make this configurable from the GUI?) - -renderCompStmts :: CDSSet -> [CompStmt] -renderCompStmts = foldl (\acc set -> acc ++ renderCompStmt set) [] - --- renderCompStmt: an observed function can be applied multiple times, each application --- is rendered to a computation statement - -renderCompStmt :: CDS -> [CompStmt] -renderCompStmt (CDSNamed name uid set) - = map mkStmt statements - where statements :: [(String,UID)] - statements = map (\(d,i) -> (pretty statementWidth d,i)) doc - doc = foldl (\a b -> a ++ renderNamedTop name uid b) [] output - output = cdssToOutput set - - mkStmt :: (String,UID) -> CompStmt - mkStmt (s,i) = CompStmt name i s - -renderNamedTop :: String -> UID -> Output -> [(Doc,UID)] -renderNamedTop name observeUid(OutData cds) - = map f pairs - where f (args,res,Just i) = (renderNamedFn name (args,res), i) - f (_,cons,Nothing) = (renderNamedCons name cons, observeUid) - pairs = (nubSorted . sortOn argAndRes) pairs' - pairs' = findFn [cds] - argAndRes (arg,res,_) = (arg,res) - - --- local nub for sorted lists -nubSorted :: Eq a => [a] -> [a] -nubSorted [] = [] -nubSorted (a:a':as) | a == a' = nub (a' : as) -nubSorted (a:as) = a : nub as - --- %************************************************************************ --- %* * --- \subsection{The CDS and converting functions} --- %* * --- %************************************************************************ - - -data CDS = CDSNamed String UID CDSSet - | CDSCons UID String [CDSSet] - | CDSFun UID CDSSet CDSSet - | CDSEntered UID - | CDSTerminated UID - deriving (Show,Eq,Ord) - -type CDSSet = [CDS] - -eventsToCDS :: [Event] -> CDSSet -eventsToCDS pairs = getChild 0 0 - where - - res i = (!) out_arr i - - bnds = (0, length pairs) - - mid_arr :: Array Int [(Int,CDS)] - mid_arr = accumArray (flip (:)) [] bnds - [ (pnode,(pport,res node)) - | (Event node (Parent pnode pport) _) <- pairs - ] - - out_arr = array bnds -- never uses 0 index - [ (node,getNode'' node e change) - | e@(Event node _ change) <- pairs - ] - - getNode'' :: Int -> Event -> Change -> CDS - getNode'' node e change = - case change of - (Observe str i) -> let chd = getChild node 0 - in CDSNamed str (getId chd i) chd - (Enter) -> CDSEntered node - (NoEnter) -> CDSTerminated node - Fun -> CDSFun node (getChild node 0) (getChild node 1) - (Cons portc cons) - -> CDSCons node cons - [ getChild node n | n <- [0..(portc-1)]] - - getId [] i = i - getId ((CDSFun i _ _ ):_) _ = i - getId (_:cs) i = getId cs i - - getChild :: Int -> Int -> CDSSet - getChild pnode pport = - [ content - | (pport',content) <- (!) mid_arr pnode - , pport == pport' - ] - -render :: Int -> Bool -> CDS -> Doc -render prec par (CDSCons _ ":" [cds1,cds2]) = - if (par && not needParen) - then doc -- dont use paren (..) because we dont want a grp here! - else paren needParen doc - where - doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <> - renderSet' 4 True cds2 - needParen = prec > 4 -render prec par (CDSCons _ "," cdss) | length cdss > 0 = - nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b) - (map renderSet cdss) <> - text ")") -render prec par (CDSCons _ name cdss) - | (not . isAlpha . head) name && length cdss > 1 = -- render as infix - paren (prec /= 0) - (grp - (renderSet' 10 False (head cdss) - <> sep <> text name - <> nest 2 (foldr (<>) nil - [ if cds == [] then nil else sep <> renderSet' 10 False cds - | cds <- tail cdss - ] - ) - ) - ) - | otherwise = -- render as prefix - paren (length cdss > 0 && prec /= 0) - ( grp - (text name <> nest 2 (foldr (<>) nil - [ sep <> renderSet' 10 False cds - | cds <- cdss - ] - ) - ) - ) - -{- renderSet handles the various styles of CDSSet. - -} - -renderSet :: CDSSet -> Doc -renderSet = renderSet' 0 False - -renderSet' :: Int -> Bool -> CDSSet -> Doc -renderSet' _ _ [] = text "_" -renderSet' prec par [cons@(CDSCons {})] = render prec par cons -renderSet' prec par cdss = - (text "{ " <> foldl1 (\ a b -> a <> line <> - text ", " <> b) - (map renderFn pairs) <> - line <> text "}") - - where - findFn_noUIDs :: CDSSet -> [([CDSSet],CDSSet)] - findFn_noUIDs c = map (\(a,r,_) -> (a,r)) (findFn c) - pairs = nub (sort (findFn_noUIDs cdss)) - -- local nub for sorted lists - nub [] = [] - nub (a:a':as) | a == a' = nub (a' : as) - nub (a:as) = a : nub as - -renderFn :: ([CDSSet],CDSSet) -> Doc -renderFn (args, res) - = grp (nest 3 - (text "\\ " <> - foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b) - nil - args <> sep <> - text "-> " <> renderSet' 0 False res - ) - ) - -renderNamedCons :: String -> CDSSet -> Doc -renderNamedCons name cons - = text name <> nest 2 - ( sep <> linebreak <> grp (text "= " <> renderSet' 0 False cons) - ) - -renderNamedFn :: String -> ([CDSSet],CDSSet) -> Doc -renderNamedFn name (args,res) - = text name <> nest 2 - ( sep <> (foldr (\ a b -> grp (renderSet' 10 False a) <> line <> b) nil args) - <> linebreak <> grp (text "= " <> renderSet' 0 False res) - ) - -findFn :: CDSSet -> [([CDSSet],CDSSet, Maybe UID)] -findFn = foldr findFn' [] - -findFn' (CDSFun i arg res) rest = - case findFn res of - [(args',res',_)] -> (arg : args', res', Just i) : rest - _ -> ([arg], res, Just i) : rest -findFn' other rest = ([],[other], Nothing) : rest - -rmEntry :: CDS -> CDS -rmEntry (CDSNamed str i set) = CDSNamed str i (rmEntrySet set) -rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets) -rmEntry (CDSFun i a b) = CDSFun i (rmEntrySet a) (rmEntrySet b) -rmEntry (CDSTerminated i) = CDSTerminated i -rmEntry (CDSEntered i) = error "found bad CDSEntered" - -rmEntrySet = map rmEntry . filter noEntered - where - noEntered (CDSEntered _) = False - noEntered _ = True - -simplifyCDS :: CDS -> CDS -simplifyCDS (CDSNamed str i set) = CDSNamed str i (simplifyCDSSet set) -simplifyCDS (CDSCons _ "throw" - [[CDSCons _ "ErrorCall" set]] - ) = simplifyCDS (CDSCons 0 "error" set) -simplifyCDS cons@(CDSCons i str sets) = - case spotString [cons] of - Just str | not (null str) -> CDSCons 0 (show str) [] - _ -> CDSCons 0 str (map simplifyCDSSet sets) - -simplifyCDS (CDSFun i a b) = CDSFun i (simplifyCDSSet a) (simplifyCDSSet b) - -simplifyCDS (CDSTerminated i) = (CDSCons i "" []) - -simplifyCDSSet = map simplifyCDS - -spotString :: CDSSet -> Maybe String -spotString [CDSCons _ ":" - [[CDSCons _ str []] - ,rest - ] - ] - = do { ch <- case reads str of - [(ch,"")] -> return ch - _ -> Nothing - ; more <- spotString rest - ; return (ch : more) - } -spotString [CDSCons _ "[]" []] = return [] -spotString other = Nothing - -paren :: Bool -> Doc -> Doc -paren False doc = grp ( doc) -paren True doc = grp ( (text "(" <> doc <> text ")")) - -data Output = OutLabel String CDSSet [Output] - | OutData CDS - deriving (Eq,Ord,Show) - -cdssToOutput :: CDSSet -> [Output] -cdssToOutput = map cdsToOutput - -cdsToOutput (CDSNamed name _ cdsset) - = OutLabel name res1 res2 - where - res1 = [ cdss | (OutData cdss) <- res ] - res2 = [ out | out@(OutLabel {}) <- res ] - res = cdssToOutput cdsset -cdsToOutput cons@(CDSCons {}) = OutData cons -cdsToOutput fn@(CDSFun {}) = OutData fn - -nil = Text.PrettyPrint.FPretty.empty -grp = Text.PrettyPrint.FPretty.group -brk = softbreak -- Nothing, if the following still fits on the current line, otherwise newline. -sep = softline -- A space, if the following still fits on the current line, otherwise newline. -sp :: Doc -sp = text " " -- A space, always. diff --git a/Debug/Hoed/Pure/Serialize.hs b/Debug/Hoed/Pure/Serialize.hs deleted file mode 100644 --- a/Debug/Hoed/Pure/Serialize.hs +++ /dev/null @@ -1,105 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon, 2016 -{-# LANGUAGE DeriveGeneric #-} - -module Debug.Hoed.Pure.Serialize -( storeJudgements -, restoreJudgements -, storeTree -, restoreTree -, storeTrace -, restoreTrace -) where -import Debug.Hoed.Pure.Observe -import Prelude hiding (lookup,Right) -import qualified Prelude as Prelude -import Debug.Hoed.Pure.CompTree -import Debug.Hoed.Pure.Render(CompStmt(..)) -import Data.Serialize -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import GHC.Generics -import Data.Graph.Libgraph(Judgement(..),AssistedMessage(..),mapGraph,Graph(..),Arc(..)) - --------------------------------------------------------------------------------- --- Derive Serialize instances - -instance (Serialize a, Serialize b) => Serialize (Graph a b) -instance (Serialize a, Serialize b) => Serialize (Arc a b) -instance Serialize Vertex -instance Serialize Judgement -instance Serialize AssistedMessage -instance Serialize CompStmt -instance Serialize Parent -instance Serialize Event -instance Serialize Change - --------------------------------------------------------------------------------- --- Tree - -storeTree :: FilePath -> CompTree -> IO () -storeTree fp = (BS.writeFile fp) . encode - -restoreTree :: FilePath -> IO (Maybe CompTree) -restoreTree fp = do - bs <- BS.readFile fp - case decode bs of - (Prelude.Left _) -> return Nothing - (Prelude.Right x) -> return (Just x) - --------------------------------------------------------------------------------- --- Trace - -storeTrace :: FilePath -> Trace -> IO () -storeTrace fp = (BS.writeFile fp) . encode - -restoreTrace :: FilePath -> IO (Maybe Trace) -restoreTrace fp = do - bs <- BS.readFile fp - case decode bs of - (Prelude.Left _) -> return Nothing - (Prelude.Right x) -> return (Just x) - --------------------------------------------------------------------------------- --- Judgements - -storeJudgements :: FilePath -> CompTree -> IO () -storeJudgements fp = (BS.writeFile fp) . encode . (foldl insert empty) . vertices - -restoreJudgements :: FilePath -> CompTree -> IO CompTree -restoreJudgements fp ct = do - bs <- BS.readFile fp - case decode bs of - (Prelude.Left _) -> return ct - (Prelude.Right db) -> return $ mapGraph (restore db) ct - -restore :: DB -> Vertex -> Vertex -restore db v = case lookup db v of - (Just Right) -> setJudgement v Right - (Just Wrong) -> setJudgement v Wrong - _ -> v - -data DB = DB [(String, Judgement)] deriving (Generic) -instance Serialize DB - -empty :: DB -empty = DB [] - -lookup :: DB -> Vertex -> Maybe Judgement -lookup (DB db) v = Prelude.lookup (key v) db - -insert :: DB -> Vertex -> DB -insert (DB db) v = case judgement v of - Nothing -> DB db - (Just j) -> DB ((key v, j) : db) - -key :: Vertex -> String -key = vertexRes - -judgement :: Vertex -> Maybe Judgement -judgement RootVertex = Nothing -judgement v = case vertexJmt v of - Right -> Just Right - Wrong -> Just Wrong - _ -> Nothing diff --git a/Debug/Hoed/Pure/TestParEq.hs b/Debug/Hoed/Pure/TestParEq.hs deleted file mode 100644 --- a/Debug/Hoed/Pure/TestParEq.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances, StandaloneDeriving, CPP, DeriveGeneric #-} - -import Debug.Hoed.Pure.Prop -import GHC.Generics hiding (moduleName) - -data A = A deriving (Eq, Generic) -instance ParEq A -data B = C B | D | E A A A | F Int Int | G B B deriving (Eq, Generic) -instance ParEq B -data H = I B B B | J Int B deriving (Eq, Generic) -instance ParEq H - -main = print $ all (==True) [t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11, - s1,s2,s3,s4,s5,s6] - -t1 = pareq_equiv A A -t2 = pareq_equiv D D -t3 = pareq_equiv (C D) D -t4 = pareq_equiv D (C D) -t5 = pareq_equiv (C (C D)) D -t6 = pareq_equiv (E A A A) D -t7 = pareq_equiv e e where e = E A A A -t8 = pareq_equiv (C (C D)) (C (C (E A A A))) -t9 = pareq_equiv (C (C D)) (C (F 4 2)) -t10 = pareq_equiv c c where c = (C (F 4 2)) -t11 = pareq_equiv c c where c = (C (F 4 2)) - -s1 = ((G (error "oeps") D) === (G D (F 4 2))) == False -s2 = ((G D (F 4 2) === (G (error "oeps") D))) == False -s3 = ((G (error "oeps") D) `parEq` (G D D)) == Nothing -s4 = (I D (E A A A) D) === (I (error "oeps") D D) == False -s5 = (I D D (E A A A)) === (I D (error "oeps") D) == False -s6 = (I (E A A A) D D) === (I D D (error "oeps")) == False - --- pareq should be equivalent to normal equality when the --- latter is conclusive -pareq_equiv x y = (x == y) == b - where (Just b) = x `parEq` y diff --git a/Debug/Hoed/ReadLine.hs b/Debug/Hoed/ReadLine.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/ReadLine.hs @@ -0,0 +1,28 @@ +module Debug.Hoed.ReadLine where +import System.IO +import Data.List + +noBuffering :: IO () +noBuffering = do + hSetBuffering stdin NoBuffering + hSetBuffering stdout NoBuffering + +readLine :: String -> [String] -> IO String +readLine ps completions = do + putStr ps + loop "" + where + loop curLine = do + c <- getChar + case c of + '\n' -> return curLine + '\DEL' -> do putStr "\b\b\b \b\b\b" + loop (case curLine of [] -> []; _ -> init curLine) + '\t' -> case filter (isPrefixOf curLine) completions of + [cmd] -> do + putStr $ drop (length curLine) cmd + loop cmd + completions' -> do + putStr $ "\b\n" ++ unlines completions' ++ ps ++ curLine + loop curLine + _ -> loop $ curLine ++ [c] diff --git a/Debug/Hoed/Render.hs b/Debug/Hoed/Render.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Render.hs @@ -0,0 +1,324 @@ +-- This file is part of the Haskell debugger Hoed. +-- +-- Copyright (c) Maarten Faddegon, 2014 +{-# LANGUAGE CPP, DeriveGeneric #-} + +module Debug.Hoed.Render +(CompStmt(..) +,renderCompStmts +,CDS +,eventsToCDS +,rmEntrySet +,simplifyCDSSet +,noNewlines +) where +import Debug.Hoed.EventForest + +import Text.PrettyPrint.FPretty hiding (sep) +import Prelude hiding(lookup) +import Debug.Hoed.Observe +import Data.List(sort,sortBy,partition,nub +#if __GLASGOW_HASKELL__ >= 710 + , sortOn +#endif + ) +import Data.Graph.Libgraph +import Data.Array as Array +import Data.Char(isAlpha) +import GHC.Generics + +#if __GLASGOW_HASKELL__ < 710 +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = map snd . sortOn' fst . map (\x -> (f x, x)) + +sortOn' :: Ord b => (a -> b) -> [a] -> [a] +sortOn' f = sortBy (\x y -> compare (f x) (f y)) +#endif + +------------------------------------------------------------------------ +-- The CompStmt type + +-- MF TODO: naming here is a bit of a mess. Needs refactoring. +-- Indentifier refers to an identifier users can explicitely give +-- to observe'. But UID is the unique number assigned to each event. +-- The field equIdentifier is not an Identifier, but the UID of the +-- event that starts the observation. And stmtUIDs is the list of +-- UIDs of all events that form the statement. + +data CompStmt = CompStmt { stmtLabel :: String + , stmtIdentifier :: UID + , stmtRes :: String + } + deriving (Eq,Ord,Generic) + +instance Show CompStmt where + show = stmtRes + showList eqs eq = unlines (map show eqs) ++ eq + +noNewlines :: String -> String +noNewlines = noNewlines' False +noNewlines' _ [] = [] +noNewlines' w (s:ss) + | w && (s == ' ' || s == '\n') = noNewlines' True ss + | (not w) && (s == ' ' || s == '\n') = ' ' : noNewlines' True ss + | otherwise = s : noNewlines' False ss + +------------------------------------------------------------------------ +-- Render equations from CDS set + +statementWidth = 110 -- 110 is good for papers (maybe make this configurable from the GUI?) + +renderCompStmts :: CDSSet -> [CompStmt] +renderCompStmts = foldl (\acc set -> acc ++ renderCompStmt set) [] + +-- renderCompStmt: an observed function can be applied multiple times, each application +-- is rendered to a computation statement + +renderCompStmt :: CDS -> [CompStmt] +renderCompStmt (CDSNamed name uid set) + = map mkStmt statements + where statements :: [(String,UID)] + statements = map (\(d,i) -> (pretty statementWidth d,i)) doc + doc = foldl (\a b -> a ++ renderNamedTop name uid b) [] output + output = cdssToOutput set + + mkStmt :: (String,UID) -> CompStmt + mkStmt (s,i) = CompStmt name i s + +renderNamedTop :: String -> UID -> Output -> [(Doc,UID)] +renderNamedTop name observeUid(OutData cds) + = map f pairs + where f (args,res,Just i) = (renderNamedFn name (args,res), i) + f (_,cons,Nothing) = (renderNamedCons name cons, observeUid) + pairs = (nubSorted . sortOn argAndRes) pairs' + pairs' = findFn [cds] + argAndRes (arg,res,_) = (arg,res) + + +-- local nub for sorted lists +nubSorted :: Eq a => [a] -> [a] +nubSorted [] = [] +nubSorted (a:a':as) | a == a' = nub (a' : as) +nubSorted (a:as) = a : nub as + +-- %************************************************************************ +-- %* * +-- \subsection{The CDS and converting functions} +-- %* * +-- %************************************************************************ + + +data CDS = CDSNamed String UID CDSSet + | CDSCons UID String [CDSSet] + | CDSFun UID CDSSet CDSSet + | CDSEntered UID + | CDSTerminated UID + deriving (Show,Eq,Ord) + +type CDSSet = [CDS] + +eventsToCDS :: [Event] -> CDSSet +eventsToCDS pairs = getChild 0 0 + where + + res i = (!) out_arr i + + bnds = (0, length pairs) + + mid_arr :: Array Int [(Int,CDS)] + mid_arr = accumArray (flip (:)) [] bnds + [ (pnode,(pport,res node)) + | (Event node (Parent pnode pport) _) <- pairs + ] + + out_arr = array bnds -- never uses 0 index + [ (node,getNode'' node e change) + | e@(Event node _ change) <- pairs + ] + + getNode'' :: Int -> Event -> Change -> CDS + getNode'' node e change = + case change of + (Observe str i) -> let chd = getChild node 0 + in CDSNamed str (getId chd i) chd + (Enter) -> CDSEntered node + (NoEnter) -> CDSTerminated node + Fun -> CDSFun node (getChild node 0) (getChild node 1) + (Cons portc cons) + -> CDSCons node cons + [ getChild node n | n <- [0..(portc-1)]] + + getId [] i = i + getId ((CDSFun i _ _ ):_) _ = i + getId (_:cs) i = getId cs i + + getChild :: Int -> Int -> CDSSet + getChild pnode pport = + [ content + | (pport',content) <- (!) mid_arr pnode + , pport == pport' + ] + +render :: Int -> Bool -> CDS -> Doc +render prec par (CDSCons _ ":" [cds1,cds2]) = + if (par && not needParen) + then doc -- dont use paren (..) because we dont want a grp here! + else paren needParen doc + where + doc = grp (sep <> renderSet' 5 False cds1 <> text " : ") <> + renderSet' 4 True cds2 + needParen = prec > 4 +render prec par (CDSCons _ "," cdss) | length cdss > 0 = + nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b) + (map renderSet cdss) <> + text ")") +render prec par (CDSCons _ name cdss) + | (not . isAlpha . head) name && length cdss > 1 = -- render as infix + paren (prec /= 0) + (grp + (renderSet' 10 False (head cdss) + <> sep <> text name + <> nest 2 (foldr (<>) nil + [ if cds == [] then nil else sep <> renderSet' 10 False cds + | cds <- tail cdss + ] + ) + ) + ) + | otherwise = -- render as prefix + paren (length cdss > 0 && prec /= 0) + ( grp + (text name <> nest 2 (foldr (<>) nil + [ sep <> renderSet' 10 False cds + | cds <- cdss + ] + ) + ) + ) + +{- renderSet handles the various styles of CDSSet. + -} + +renderSet :: CDSSet -> Doc +renderSet = renderSet' 0 False + +renderSet' :: Int -> Bool -> CDSSet -> Doc +renderSet' _ _ [] = text "_" +renderSet' prec par [cons@(CDSCons {})] = render prec par cons +renderSet' prec par cdss = + (text "{ " <> foldl1 (\ a b -> a <> line <> + text ", " <> b) + (map renderFn pairs) <> + line <> text "}") + + where + findFn_noUIDs :: CDSSet -> [([CDSSet],CDSSet)] + findFn_noUIDs c = map (\(a,r,_) -> (a,r)) (findFn c) + pairs = nub (sort (findFn_noUIDs cdss)) + -- local nub for sorted lists + nub [] = [] + nub (a:a':as) | a == a' = nub (a' : as) + nub (a:as) = a : nub as + +renderFn :: ([CDSSet],CDSSet) -> Doc +renderFn (args, res) + = grp (nest 3 + (text "\\ " <> + foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b) + nil + args <> sep <> + text "-> " <> renderSet' 0 False res + ) + ) + +renderNamedCons :: String -> CDSSet -> Doc +renderNamedCons name cons + = text name <> nest 2 + ( sep <> linebreak <> grp (text "= " <> renderSet' 0 False cons) + ) + +renderNamedFn :: String -> ([CDSSet],CDSSet) -> Doc +renderNamedFn name (args,res) + = text name <> nest 2 + ( sep <> (foldr (\ a b -> grp (renderSet' 10 False a) <> line <> b) nil args) + <> linebreak <> grp (text "= " <> renderSet' 0 False res) + ) + +findFn :: CDSSet -> [([CDSSet],CDSSet, Maybe UID)] +findFn = foldr findFn' [] + +findFn' (CDSFun i arg res) rest = + case findFn res of + [(args',res',_)] -> (arg : args', res', Just i) : rest + _ -> ([arg], res, Just i) : rest +findFn' other rest = ([],[other], Nothing) : rest + +rmEntry :: CDS -> CDS +rmEntry (CDSNamed str i set) = CDSNamed str i (rmEntrySet set) +rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets) +rmEntry (CDSFun i a b) = CDSFun i (rmEntrySet a) (rmEntrySet b) +rmEntry (CDSTerminated i) = CDSTerminated i +rmEntry (CDSEntered i) = error "found bad CDSEntered" + +rmEntrySet = map rmEntry . filter noEntered + where + noEntered (CDSEntered _) = False + noEntered _ = True + +simplifyCDS :: CDS -> CDS +simplifyCDS (CDSNamed str i set) = CDSNamed str i (simplifyCDSSet set) +simplifyCDS (CDSCons _ "throw" + [[CDSCons _ "ErrorCall" set]] + ) = simplifyCDS (CDSCons 0 "error" set) +simplifyCDS cons@(CDSCons i str sets) = + case spotString [cons] of + Just str | not (null str) -> CDSCons 0 (show str) [] + _ -> CDSCons 0 str (map simplifyCDSSet sets) + +simplifyCDS (CDSFun i a b) = CDSFun i (simplifyCDSSet a) (simplifyCDSSet b) + +simplifyCDS (CDSTerminated i) = (CDSCons i "" []) + +simplifyCDSSet = map simplifyCDS + +spotString :: CDSSet -> Maybe String +spotString [CDSCons _ ":" + [[CDSCons _ str []] + ,rest + ] + ] + = do { ch <- case reads str of + [(ch,"")] -> return ch + _ -> Nothing + ; more <- spotString rest + ; return (ch : more) + } +spotString [CDSCons _ "[]" []] = return [] +spotString other = Nothing + +paren :: Bool -> Doc -> Doc +paren False doc = grp ( doc) +paren True doc = grp ( (text "(" <> doc <> text ")")) + +data Output = OutLabel String CDSSet [Output] + | OutData CDS + deriving (Eq,Ord,Show) + +cdssToOutput :: CDSSet -> [Output] +cdssToOutput = map cdsToOutput + +cdsToOutput (CDSNamed name _ cdsset) + = OutLabel name res1 res2 + where + res1 = [ cdss | (OutData cdss) <- res ] + res2 = [ out | out@(OutLabel {}) <- res ] + res = cdssToOutput cdsset +cdsToOutput cons@(CDSCons {}) = OutData cons +cdsToOutput fn@(CDSFun {}) = OutData fn + +nil = Text.PrettyPrint.FPretty.empty +grp = Text.PrettyPrint.FPretty.group +brk = softbreak -- Nothing, if the following still fits on the current line, otherwise newline. +sep = softline -- A space, if the following still fits on the current line, otherwise newline. +sp :: Doc +sp = text " " -- A space, always. diff --git a/Debug/Hoed/Serialize.hs b/Debug/Hoed/Serialize.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Serialize.hs @@ -0,0 +1,105 @@ +-- This file is part of the Haskell debugger Hoed. +-- +-- Copyright (c) Maarten Faddegon, 2016 +{-# LANGUAGE DeriveGeneric #-} + +module Debug.Hoed.Serialize +( storeJudgements +, restoreJudgements +, storeTree +, restoreTree +, storeTrace +, restoreTrace +) where +import Debug.Hoed.Observe +import Prelude hiding (lookup,Right) +import qualified Prelude as Prelude +import Debug.Hoed.CompTree +import Debug.Hoed.Render(CompStmt(..)) +import Data.Serialize +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import GHC.Generics +import Data.Graph.Libgraph(Judgement(..),AssistedMessage(..),mapGraph,Graph(..),Arc(..)) + +-------------------------------------------------------------------------------- +-- Derive Serialize instances + +instance (Serialize a, Serialize b) => Serialize (Graph a b) +instance (Serialize a, Serialize b) => Serialize (Arc a b) +instance Serialize Vertex +instance Serialize Judgement +instance Serialize AssistedMessage +instance Serialize CompStmt +instance Serialize Parent +instance Serialize Event +instance Serialize Change + +-------------------------------------------------------------------------------- +-- Tree + +storeTree :: FilePath -> CompTree -> IO () +storeTree fp = (BS.writeFile fp) . encode + +restoreTree :: FilePath -> IO (Maybe CompTree) +restoreTree fp = do + bs <- BS.readFile fp + case decode bs of + (Prelude.Left _) -> return Nothing + (Prelude.Right x) -> return (Just x) + +-------------------------------------------------------------------------------- +-- Trace + +storeTrace :: FilePath -> Trace -> IO () +storeTrace fp = (BS.writeFile fp) . encode + +restoreTrace :: FilePath -> IO (Maybe Trace) +restoreTrace fp = do + bs <- BS.readFile fp + case decode bs of + (Prelude.Left _) -> return Nothing + (Prelude.Right x) -> return (Just x) + +-------------------------------------------------------------------------------- +-- Judgements + +storeJudgements :: FilePath -> CompTree -> IO () +storeJudgements fp = (BS.writeFile fp) . encode . (foldl insert empty) . vertices + +restoreJudgements :: FilePath -> CompTree -> IO CompTree +restoreJudgements fp ct = do + bs <- BS.readFile fp + case decode bs of + (Prelude.Left _) -> return ct + (Prelude.Right db) -> return $ mapGraph (restore db) ct + +restore :: DB -> Vertex -> Vertex +restore db v = case lookup db v of + (Just Right) -> setJudgement v Right + (Just Wrong) -> setJudgement v Wrong + _ -> v + +data DB = DB [(String, Judgement)] deriving (Generic) +instance Serialize DB + +empty :: DB +empty = DB [] + +lookup :: DB -> Vertex -> Maybe Judgement +lookup (DB db) v = Prelude.lookup (key v) db + +insert :: DB -> Vertex -> DB +insert (DB db) v = case judgement v of + Nothing -> DB db + (Just j) -> DB ((key v, j) : db) + +key :: Vertex -> String +key = vertexRes + +judgement :: Vertex -> Maybe Judgement +judgement RootVertex = Nothing +judgement v = case vertexJmt v of + Right -> Just Right + Wrong -> Just Wrong + _ -> Nothing diff --git a/Debug/Hoed/Stk.hs b/Debug/Hoed/Stk.hs deleted file mode 100644 --- a/Debug/Hoed/Stk.hs +++ /dev/null @@ -1,245 +0,0 @@ -{-| -Module : Debug.Hoed.Stk -Description : Lighweight algorithmic debugging based on observing intermediate values and the cost centre stack. -Copyright : (c) 2000 Andy Gill, (c) 2010 University of Kansas, (c) 2013-2014 Maarten Faddegon -License : BSD3 -Maintainer : hoed@maartenfaddegon.nl -Stability : experimental -Portability : POSIX - -Hoed.Stk is a tracer and debugger for the programming language Haskell. You can -trace a program by annotating functions in suspected modules and linking your -program against standard profiling libraries. - -Hoed.Pure is recommended over Hoed.Stk because to debug your program with Hoed.Pure you can optimize your program and do not need to enable profiling. - -After running the program a computation tree is constructed and displayed in a -web browser. You can freely browse this tree to get a better understanding of -your program. If your program misbehaves, you can judge the computation -statements in the tree as 'right' or 'wrong' according to your intention. When -enough statements are judged the debugger tells you the location of the fault -in your code. - -<> - -I work on this debugger in the context of my Ph.D. research. -Read more about the theory behind Hoed at . - -To use Hoed on your own program, annotate your program as described below. -For best results profiling is enabled and optimization disabled. -If you use cabal to build your project, this is be done with: - -> cabal configure --disable-optimization --enable-profiling - -I am keen to hear about your experience with Hoed: -where did you find it useful and where would you like to see improvement? -You can send me an e-mail at hoed@maartenfaddegon.nl, or use the -github issue tracker . - --} - -module Debug.Hoed.Stk - ( -- * Basic annotations - observe - , runO - , printO - - -- * Experimental annotations - , observeTempl - , observedTypes - , observeCC - , observe' - , Identifier(..) - -- ,(*>>=),(>>==),(>>=*) - , logO - - -- * The Observable class - , Observer(..) - , Observable(..) - , (<<) - , thunk - , nothunk - , send - , observeBase - , observeOpaque - , debugO - , CDS(..) - , Generic - ) where - - -import Debug.Hoed.Stk.Observe -import Debug.Hoed.Stk.Render -import Debug.Hoed.Stk.DemoGUI - -import Prelude hiding (Right) -import qualified Prelude -import System.IO -import Data.Maybe -import Control.Monad -import Data.Array as Array -import Data.List -import Data.Char -import System.Environment - -import Language.Haskell.TH -import GHC.Generics - -import Data.IORef -import System.IO.Unsafe -import Data.Graph.Libgraph -import Graphics.UI.Threepenny(startGUI,defaultConfig,Config(..)) - -import System.Directory(createDirectoryIfMissing) - - --- %************************************************************************ --- %* * --- \subsection{External start functions} --- %* * --- %************************************************************************ - --- Run the observe ridden code. - --- | run some code and return the CDS structure (for when you want to write your own debugger). -debugO :: IO a -> IO [Event] -debugO program = - do { initUniq - ; startEventStream - ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]" - ; ourCatchAllIO (do { program ; return () }) - (hPutStrLn stderr . errorMsg) - ; events <- endEventStream - ; return events - } - --- | Short for @runO . print@. -printO :: (Show a) => a -> IO () -printO expr = runO (print expr) - --- | The main entry point; run some IO code, and debug inside it. --- After the IO action is completed, an algorithmic debugging session is started at --- @http://localhost:10000/@ to which you can connect with your webbrowser. --- --- For example: --- --- @ --- main = runO $ do print (triple 3) --- print (triple 2) --- @ --- - -runO :: IO a -> IO () -runO program = {- SCC "runO" -} do - let slices = [] -- MF TODO: this whole slices business should probably just go? - compGraph <- runO' program - debugSession slices compGraph - return () - -runO' :: IO a -> IO CompGraph -runO' program = {- SCC "runO" -} do - args <- getArgs - setPushMode (parseArgs args) - hPutStrLn stderr "=== program output ===\n" - events <- debugO program - let cdss = eventsToCDS events - let cdss1 = rmEntrySet cdss - let cdss2 = simplifyCDSSet cdss1 - let eqs = ((sortBy byStack) . renderCompStmts) cdss2 - let ct = mkGraph eqs - - hPutStrLn stderr "\n=== Statistics ===\n" - let e = length events - n = length eqs - b = fromIntegral (length . arcs $ ct ) / fromIntegral ((length . vertices $ ct) - (length . leafs $ ct)) - hPutStrLn stderr $ show e ++ " events" - hPutStrLn stderr $ show n ++ " computation statements" - hPutStrLn stderr $ show ((length . vertices $ ct) - 1) ++ " nodes + 1 virtual root node in the computation tree" - hPutStrLn stderr $ show (length . arcs $ ct) ++ " edges in computation tree" - hPutStrLn stderr $ "computation tree has a branch factor of " ++ show b ++ " (i.e the average number of children of non-leaf nodes)" - - hPutStrLn stderr "\n=== Debug session === \n" - -- hPutStrLn stderr (showWithStack eqs) - return ct - -leafs g = filter (\v -> succs g v == []) (vertices g) - -logO :: FilePath -> IO a -> IO () -logO filePath program = {- SCC "logO" -} do - compGraph <- runO' program - writeFile filePath (showGraph compGraph) - return () - - where showGraph g = showWith g showVertex showArc - showVertex Root = ("root","") - showVertex v = ("\"" ++ (escape . showCompStmts) v ++ "\nwith stack " - ++ (showStk . equStack . head . equations $ v) ++ "\"", "") - showArc _ = "" - showCompStmts = showCompStmts' . equations - showCompStmts' [e] = show e - showCompStmts' es = foldl (\acc e-> acc ++ show e ++ ", ") "{" (init es) - ++ show (last es) ++ "}" - showStk [] = "[]" - showStk stk = showStk' $ map (\lbl -> "\\\"" ++ lbl ++ "\\\"") stk - showStk' (h:lbls) = foldl (\lbl acc -> lbl ++ (',' : acc)) ('[' : h) lbls ++ "]" - ------------------------------------------------------------------------- --- Push mode option handling - -data PushMode = Vanilla | Drop | Truncate - -pushMode :: IORef PushMode -pushMode = unsafePerformIO $ newIORef Vanilla - -setPushMode :: PushMode -> IO () -setPushMode = writeIORef pushMode - -getPushMode :: PushMode -getPushMode = unsafePerformIO $ readIORef pushMode - --- MF TODO: handle a bit nicer? -parseArgs :: [String] -> PushMode -parseArgs [] = Truncate -- default mode -parseArgs (arg:_) = case arg of - "--PushVanilla" -> Vanilla - "--PushDrop" -> Drop - "--PushTruncate" -> Truncate - _ -> error ("unknown option " ++ arg) - - ------------------------------------------------------------------------- --- Algorithmic Debugging - -debugSession :: [(String,String)] -> CompGraph -> IO () -debugSession slices tree - = do createDirectoryIfMissing True ".Hoed/wwwroot/css" - writeFile ".Hoed/wwwroot/debug.css" stylesheet - treeRef <- newIORef tree - startGUI defaultConfig - { jsPort = Just 10000 - , jsStatic = Just "./.Hoed/wwwroot" - } (demoGUI slices treeRef) - - -stylesheet - = "div {\n" - ++ " padding:0;\n" - ++ " margin:0;\n" - ++ "}\n" - ++ ".buttons {\n" - ++ " float:top;\n" - ++ " height:50vh;\n" - ++ " overflow-y: scroll;\n" - ++ " overflow-x: hidden;\n" - ++ "}\n" - ++ ".nowrap {\n" - ++ " white-space: nowrap;\n" - ++ "}\n" - ++ ".odd {\n" - ++ " background-color: lightgray;\n" - ++ " padding: 10px 0;\n" - ++ "}\n" - ++ ".even {\n" - ++ " background-color: white;\n" - ++ " padding: 10px 0;\n" - ++ "}\n" diff --git a/Debug/Hoed/Stk/DemoGUI.hs b/Debug/Hoed/Stk/DemoGUI.hs deleted file mode 100644 --- a/Debug/Hoed/Stk/DemoGUI.hs +++ /dev/null @@ -1,300 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon, 2014-2015 - -module Debug.Hoed.Stk.DemoGUI -where - -import Prelude hiding(Right) -import Debug.Hoed.Stk.Render -import Data.Graph.Libgraph -import qualified Graphics.UI.Threepenny as UI -import Graphics.UI.Threepenny (startGUI,defaultConfig, Window, UI, (#), (#+), (#.), string, on,get,set) -import System.Process(system) -import Data.IORef -import Data.List(intersperse,nub) -import Text.Regex.Posix - --------------------------------------------------------------------------------- --- The tabbed layout from which we select the different views - -preorder :: CompGraph -> [Vertex] -preorder = getPreorder . getDfs - -showStmt :: UI.Element -> IORef [Vertex] -> IORef Int -> UI () -showStmt e filteredVerticesRef currentVertexRef = do - mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef - let s = case mv of - Nothing -> "Select vertex above to show details." - (Just v) -> showCompStmts v - UI.element e # UI.set UI.text s - return () - -data Filter = ShowAll | ShowSucc | ShowPred | ShowMatch - -demoGUI :: [(String,String)] -> IORef CompGraph -> Window -> UI () -demoGUI sliceDict treeRef window - = do return window # UI.set UI.title "Hoed debugging session" - UI.addStyleSheet window "debug.css" - - -- Get a list of vertices from the computation graph - tree <- UI.liftIO $ readIORef treeRef - let ns = filter (not . isRoot) (preorder tree) - - -- Shared memory - filteredVerticesRef <- UI.liftIO $ newIORef ns - currentVertexRef <- UI.liftIO $ newIORef (0 :: Int) - regexRef <- UI.liftIO $ newIORef "" - imgCountRef <- UI.liftIO $ newIORef (0 :: Int) - - -- Draw the computation graph - img <- UI.img - redraw img imgCountRef treeRef (Just $ head ns) - img' <- UI.center #+ [UI.element img] - - -- Field to show computation statement(s) of current vertex - compStmt <- UI.pre - - -- Menu to select which statement to show - menu <- UI.select - showStmt compStmt filteredVerticesRef currentVertexRef - updateMenu menu treeRef currentVertexRef filteredVerticesRef - let selectVertex' = selectVertex compStmt filteredVerticesRef currentVertexRef $ redrawWith img imgCountRef treeRef - on UI.selectionChange menu selectVertex' - - -- Buttons for the various filters - filterTxt <- UI.span # UI.set UI.text "Filters: " - showAllBut <- UI.button # UI.set UI.text "Show all" - showSuccBut <- UI.button # UI.set UI.text "Show successors" - showPredBut <- UI.button # UI.set UI.text "Show predecessors" - showMatchBut <- UI.button # UI.set UI.text "Matches " - matchField <- UI.input - filters <- UI.div #+ (map return [ filterTxt, showAllBut, showSuccBut, showPredBut - , showMatchBut, matchField]) - - on UI.valueChange matchField $ \s -> UI.liftIO $ writeIORef regexRef s - let onClickFilter' = onClickFilter menu treeRef currentVertexRef filteredVerticesRef - selectVertex' regexRef - onClickFilter' showAllBut ShowAll - onClickFilter' showSuccBut ShowSucc - onClickFilter' showPredBut ShowPred - onClickFilter' showMatchBut ShowMatch - - -- Status - statusSpan <- UI.span - updateStatus statusSpan treeRef - - -- Buttons to judge the current statement - right <- UI.button # UI.set UI.text "right" - wrong <- UI.button # UI.set UI.text "wrong" - let onJudge = onClick statusSpan menu img imgCountRef treeRef - currentVertexRef filteredVerticesRef - onJudge right Right - onJudge wrong Wrong - - -- Populate the main screen - hr <- UI.hr - UI.getBody window #+ (map UI.element [filters, menu, right, wrong, statusSpan - , compStmt, hr,img']) - return () - -updateMenu :: UI.Element -> IORef CompGraph - -> IORef Int -> IORef [Vertex] -> UI () -updateMenu menu treeRef currentVertexRef filteredVerticesRef = do - g <- UI.liftIO $ readIORef treeRef - i <- UI.liftIO $ readIORef currentVertexRef - ns <- UI.liftIO $ readIORef filteredVerticesRef - let fs = faultyVertices g - ops <- mapM (\s->UI.option # UI.set UI.text s) - $ if ns == [] then ["No matches found"] - else map (summarizeVertex fs) ns - (UI.element menu) # UI.set UI.children [] - UI.element menu #+ (map UI.element ops) - (UI.element menu) # UI.set UI.selection (Just i) - return () - -vertexFilter :: Filter -> CompGraph -> Vertex -> String -> [Vertex] -vertexFilter f g cv r = filter (not . isRoot) $ case f of - ShowAll -> preorder g - ShowSucc -> succs g cv - ShowPred -> preds g cv - ShowMatch -> filter matches (preorder g) - where matches Root = False - matches v = showCompStmts v =~ r - -onClick :: UI.Element -> UI.Element -> UI.Element - -> IORef Int -> IORef CompGraph -> IORef Int -> IORef [Vertex] - -> UI.Element -> Judgement-> UI () -onClick statusSpan menu img imgCountRef treeRef currentVertexRef filteredVerticesRef b j = do - on UI.click b $ \_ -> do - (Just v) <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef - replaceFilteredVertex v (newStatus v j) - updateTree img imgCountRef treeRef (Just v) (\tree -> markNode tree v j) - updateMenu menu treeRef currentVertexRef filteredVerticesRef - updateStatus statusSpan treeRef - - where replaceFilteredVertex v w = do - vs <- UI.liftIO $ readIORef filteredVerticesRef - UI.liftIO $ writeIORef filteredVerticesRef $ map (\x -> if x == v then w else x) vs - -newStatus Root _ = Root -newStatus v j = v{status=j} - -lookupCurrentVertex :: IORef Int -> IORef [Vertex] -> IO (Maybe Vertex) -lookupCurrentVertex currentVertexRef filteredVerticesRef = do - i <- readIORef currentVertexRef - m <- readIORef filteredVerticesRef - return $ if i < length m then Just (m !! i) else Nothing - --- onSelectVertex :: UI.Element -> UI.Element -> IORef [Vertex] -> IORef Int --- -> (IORef [Vertex] -> IORef Int -> UI ()) -> UI () --- onSelectVertex menu compStmt filteredVerticesRef currentVertexRef myRedraw = do --- on UI.selectionChange menu $ \mi -> case mi of --- Just i -> do UI.liftIO $ writeIORef currentVertexRef i --- showStmt compStmt filteredVerticesRef currentVertexRef --- myRedraw filteredVerticesRef currentVertexRef --- return () --- Nothing -> return () - -selectVertex :: UI.Element -> IORef [Vertex] -> IORef Int - -> (IORef [Vertex] -> IORef Int -> UI ()) -> Maybe Int -> UI () -selectVertex compStmt filteredVerticesRef currentVertexRef myRedraw mi = case mi of - Just i -> do UI.liftIO $ writeIORef currentVertexRef i - showStmt compStmt filteredVerticesRef currentVertexRef - myRedraw filteredVerticesRef currentVertexRef - return () - Nothing -> return () - - -onClickFilter :: UI.Element -> IORef CompGraph -> IORef Int -> IORef [Vertex] - -> (Maybe Int -> UI ()) -> IORef String -> UI.Element -> Filter -> UI () -onClickFilter menu treeRef currentVertexRef filteredVerticesRef selectVertex' regexRef e fil = do - on UI.click e $ \_ -> do - mcv <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef - g <- UI.liftIO $ readIORef treeRef - r <- UI.liftIO $ readIORef regexRef - let cv = case mcv of (Just v) -> v - Nothing -> head . (filter $ not . isRoot) . preorder $ g - applyFilter f = do UI.liftIO $ writeIORef filteredVerticesRef (vertexFilter f g cv r) - UI.liftIO $ writeIORef currentVertexRef 0 - applyFilter fil - updateMenu menu treeRef currentVertexRef filteredVerticesRef - selectVertex' (Just 0) - --- MF TODO: We may need to reconsider how Vertex is defined, --- and how we determine equality. I think it could happen that --- two vertices with equal equation but different stacks/relations --- are now both changed. -markNode :: CompGraph -> Vertex -> Judgement -> CompGraph -markNode g v s = mapGraph f g - where f Root = Root - f v' = if v' === v then newStatus v s else v' - - (===) :: Vertex -> Vertex -> Bool - Root === v = v == Root - v1 === v2 = (equations v1) == (equations v2) - -data MaxStringLength = ShorterThan Int | Unlimited - -shorten :: MaxStringLength -> String -> String -shorten Unlimited s = s -shorten (ShorterThan l) s - | length s < l = s - | l > 3 = take (l - 3) s ++ "..." - | otherwise = take l s - --- MF TODO: Maybe we should do something smart with witespace substitution here? -noNewlines :: String -> String -noNewlines = filter (/= '\n') - -showCompStmts :: Vertex -> String -showCompStmts = commas . equations' - where equations' Root = ["Root"] - equations' v = map show . equations $ v - -summarizeVertex :: [Vertex] -> Vertex -> String -summarizeVertex fs v = shorten (ShorterThan 27) (noNewlines $ showCompStmts v) ++ s - where s = if v `elem` fs then " !!" else case getStatus v of - Unassessed -> " ??" - Wrong -> " :(" - Right -> " :)" - -updateStatus :: UI.Element -> IORef CompGraph -> UI () -updateStatus e compGraphRef = do - g <- UI.liftIO $ readIORef compGraphRef - let getLabel Root = "Root" - getLabel v = commas . (map equLabel) . equations $ v - isJudged v = getStatus v /= Unassessed - slen = show . length - ns = filter (not . isRoot) (preorder g) - js = filter isJudged ns - fs = faultyVertices g - txt = if length fs > 0 then " Fault detected in: " ++ getLabel (head fs) - else " Judged " ++ slen js ++ "/" ++ slen ns - UI.element e # UI.set UI.text txt - return () - -updateTree :: UI.Element -> IORef Int -> IORef CompGraph -> (Maybe Vertex) -> (CompGraph -> CompGraph) - -> UI () -updateTree img imgCountRef treeRef mcv f - = do tree <- UI.liftIO $ readIORef treeRef - UI.liftIO $ writeIORef treeRef (f tree) - redraw img imgCountRef treeRef mcv - -redrawWith :: UI.Element -> IORef Int -> IORef CompGraph -> IORef [Vertex] -> IORef Int -> UI () -redrawWith img imgCountRef treeRef filteredVerticesRef currentVertexRef = do - mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef - redraw img imgCountRef treeRef mv - -redraw :: UI.Element -> IORef Int -> IORef CompGraph -> (Maybe Vertex) -> UI () -redraw img imgCountRef treeRef mcv - = do tree <- UI.liftIO $ readIORef treeRef - -- replace with the following line to "summarize" big trees by - -- dropping some nodes - --UI.liftIO $ writeFile ".Hoed/debugTree.dot" (shw $ summarize tree mcv) - UI.liftIO $ writeFile ".Hoed/debugTree.dot" (shw tree) - UI.liftIO $ system $ "dot -Tpng -Gsize=9,5 -Gdpi=100 .Hoed/debugTree.dot " - ++ "> .Hoed/wwwroot/debugTree.png" - i <- UI.liftIO $ readIORef imgCountRef - UI.liftIO $ writeIORef imgCountRef (i+1) - -- Attach counter to image url to reload image - UI.element img # set UI.src ("static/debugTree.png#" ++ show i) - return () - - where shw g = showWith g (coloVertex $ faultyVertices g) showArc - coloVertex _ Root = ("\".\"", "shape=none") - coloVertex fs v = ( "\"" ++ escape (summarizeVertex fs v) ++ "\"" - , if isCurrentVertex mcv v then "style=filled fillcolor=yellow" - else "" - ) - showArc _ = "" - --- MF TODO: summarize now just "throws away" some vertices if there are too --- many. Better would be to inject summarizing nodes (e.g. "and 25 more"). -summarize :: CompGraph -> Maybe Vertex -> CompGraph -summarize g mcv = Graph (root g) keep as - where keep1 v = take 7 $ succs g v - keep' = nub $ Root : foldl (\ks v -> ks ++ keep1 v) [] (vertices g) - keep = case filter (isCurrentVertex mcv) (vertices g) of - [] -> keep' - (w:_) -> if w `elem` keep' then keep' else w : keep - as = filter (\(Arc v w _) -> v `elem` keep && w `elem` keep) (arcs g) - -isCurrentVertex :: Maybe Vertex -> Vertex -> Bool -isCurrentVertex mcv v = case v of - Root -> False - _ -> case mcv of - Nothing -> False - (Just Root) -> False - (Just w) -> equations v == equations w - -commas :: [String] -> String -commas [] = error "commas: empty list" -commas [e] = e -commas es = foldl (\acc e-> acc ++ e ++ ", ") "{" (init es) ++ (last es) ++ "}" - -faultyVertices :: CompGraph -> [Vertex] -faultyVertices = findFaulty_dag getStatus - -getStatus Root = Right -getStatus v = status v diff --git a/Debug/Hoed/Stk/Observe.lhs b/Debug/Hoed/Stk/Observe.lhs deleted file mode 100644 --- a/Debug/Hoed/Stk/Observe.lhs +++ /dev/null @@ -1,1193 +0,0 @@ -\begin{code} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -O0 #-} - -\end{code} - -The file is part of the Haskell Object Observation Debugger, -(HOOD) March 2010 release. - -HOOD is a small post-mortem debugger for the lazy functional -language Haskell. It is based on the concept of observation of -intermediate data structures, rather than the more traditional -stepping and variable examination paradigm used by imperative -language debuggers. - -Copyright (c) Andy Gill, 1992-2000 -Copyright (c) The University of Kansas 2010 -Copyright (c) Maarten Faddegon, 2013-2014 - -All rights reserved. HOOD is distributed as free software under -the license in the file "License", which available from the HOOD -web page, http://www.haskell.org/hood - -This module produces CDS's, based on the observation made on Haskell -objects, including base types, constructors and functions. - -WARNING: unrestricted use of unsafePerformIO below. - -This was ported for the version found on www.haskell.org/hood. - - -%************************************************************************ -%* * -\subsection{Exports} -%* * -%************************************************************************ - -\begin{code} -module Debug.Hoed.Stk.Observe - ( - -- * The main Hood API - - observeTempl - , observe - , observe' - , observeCC - , Observer(..) -- contains a 'forall' typed observe (if supported). - -- , Observing -- a -> a - , Observable(..) -- Class - - -- * For advanced users, that want to render their own datatypes. - , (<<) -- (Observable a) => ObserverM (a -> b) -> a -> ObserverM b - -- ,(*>>=),(>>==),(>>=*) - , thunk -- (Observable a) => a -> ObserverM a - , nothunk - , send - , observeBase - , observeOpaque - , observedTypes - , Generic - , CallStack - , emptyStack - , Event(..) - , Change(..) - , Parent(..) - , ThreadId(..) - , Identifier(..) - , initUniq - , startEventStream - , endEventStream - , ourCatchAllIO - , peepUniq - , ccsToStrings - ) where -\end{code} - - -%************************************************************************ -%* * -\subsection{Imports and infixing} -%* * -%************************************************************************ - -\begin{code} -import Prelude hiding (Right) -import qualified Prelude -import System.IO -import Data.Maybe -import Control.Monad -import Data.Array as Array -import Data.List -import Data.Char -import System.Environment - -import Language.Haskell.TH -import GHC.Generics - -import Data.IORef -import System.IO.Unsafe - -import Control.Concurrent(takeMVar,putMVar,MVar,newMVar) -import qualified Control.Concurrent as Concurrent -\end{code} - -Needed to access the cost centre stack: -\begin{code} -import GHC.Stack (ccLabel, getCurrentCCS, CostCentreStack,ccsCC,ccsParent,currentCallStack) -import GHC.Foreign as GHC -import GHC.Ptr -\end{code} - -For the TracedMonad instance of IO: -\begin{code} -import GHC.Base hiding (mapM) -\end{code} - -\begin{code} -import qualified Control.Exception as Exception -import Control.Exception (Exception, throw, ErrorCall(..), SomeException(..)) -{- - ( catch - , Exception(..) - , throw - ) as Exception --} -import Data.Dynamic ( Dynamic ) -\end{code} - -\begin{code} -infixl 9 << -\end{code} - - -%************************************************************************ -%* * -\subsection{GDM Generics} -%* * -%************************************************************************ - -he generic implementation of the observer function. - -\begin{code} -class Observable a where - observer :: a -> Parent -> a - default observer :: (Generic a, GObservable (Rep a)) => a -> Parent -> a - observer x c = to (gdmobserver (from x) c) - -class GObservable f where - gdmobserver :: f a -> Parent -> f a - gdmObserveChildren :: f a -> ObserverM (f a) - gdmShallowShow :: f a -> String -\end{code} - -Creating a shallow representation for types of the Data class. - -\begin{code} - --- shallowShow :: Constructor c => t c (f :: * -> *) a -> [Char] --- shallowShow = conName - -\end{code} - -Observing the children of Data types of kind *. - -\begin{code} - --- Meta: data types -instance (GObservable a) => GObservable (M1 D d a) where - gdmobserver m@(M1 x) cxt = M1 (gdmobserver x cxt) - gdmObserveChildren = gthunk - gdmShallowShow = undefined - --- Meta: Constructors -instance (GObservable a, Constructor c) => GObservable (M1 C c a) where - gdmobserver m@(M1 x) cxt = M1 (send (gdmShallowShow m) (gdmObserveChildren x) cxt) - gdmObserveChildren = gthunk - gdmShallowShow = conName - --- Meta: Selectors --- | selName m == "" = M1 y --- | otherwise = M1 (send (selName m) (return y) cxt) -instance (GObservable a, Selector s) => GObservable (M1 S s a) where - gdmobserver m@(M1 x) cxt - | selName m == "" = M1 (gdmobserver x cxt) - | otherwise = M1 (send (selName m ++ " =") (gdmObserveChildren x) cxt) - gdmObserveChildren = gthunk - gdmShallowShow = undefined - --- Unit: used for constructors without arguments -instance GObservable U1 where - gdmobserver x _ = x - gdmObserveChildren = return - gdmShallowShow = undefined - --- Products: encode multiple arguments to constructors -instance (GObservable a, GObservable b) => GObservable (a :*: b) where - gdmobserver (a :*: b) cxt = error "gdmobserver product" - - gdmObserveChildren (a :*: b) = do a' <- gdmObserveChildren a - b' <- gdmObserveChildren b - return (a' :*: b') - - gdmShallowShow = undefined - --- Sums: encode choice between constructors -instance (GObservable a, GObservable b) => GObservable (a :+: b) where - gdmobserver (L1 x) cxt = L1 (gdmobserver x cxt) - gdmobserver (R1 x) cxt = R1 (gdmobserver x cxt) - - gdmObserveChildren (R1 x) = do {x' <- gdmObserveChildren x; return (R1 x')} - gdmObserveChildren (L1 x) = do {x' <- gdmObserveChildren x; return (L1 x')} - - gdmShallowShow = undefined - --- Constants: additional parameters and recursion of kind * -instance (Observable a) => GObservable (K1 i a) where - gdmobserver (K1 x) cxt = K1 (observer x cxt) - - gdmObserveChildren = gthunk - - gdmShallowShow = undefined -\end{code} - -Observing functions is done via the ad-hoc mechanism, because -we provide an instance definition the default is ignored for -this type. - -\begin{code} -instance (Observable a,Observable b) => Observable (a -> b) where - observer fn cxt arg = gdmFunObserver cxt fn arg -\end{code} - -Observing the children of Data types of kind *->*. - -\begin{code} -gdmFunObserver :: (Observable a,Observable b) => Parent -> (a->b) -> (a->b) -gdmFunObserver cxt fn arg - = let (app,stack) = getStack - $ sendObserveFnPacket stack - (do arg' <- thunk observer arg - thunk observer (fn arg') - ) cxt - in app -\end{code} - - - - -%************************************************************************ -%* * -\subsection{Cost Centre Stack} -%* * -%************************************************************************ - -\begin{code} - -type CallStack = [String] -emptyStack = [""] - -{-# NOINLINE getStack #-} -getStack :: a -> (a, CallStack) -getStack x = let stack = unsafePerformIO - $ do {ccs <- getCurrentCCS (); ccsToStrings ccs} - in (x, rev stack) - where rev [] = [] - -- rev s = reverse (tail s) - rev (h:s) = let s' = case h of "CAF" -> s - _ -> h:s - in reverse s' - - -ccsToStrings :: Ptr CostCentreStack -> IO [String] -ccsToStrings ccs0 = go ccs0 [] - where - go ccs acc - | ccs == nullPtr = return acc - | otherwise = do - cc <- ccsCC ccs - lbl <- GHC.peekCString utf8 =<< ccLabel cc - parent <- ccsParent ccs - if (lbl == "MAIN") - then return acc - else go parent (lbl : acc) - - -\end{code} - - -%************************************************************************ -%* * -\subsection{Generics} -%* * -%************************************************************************ - -Generate a new observe from generated observers and the gobserve mechanism. -Where gobserve is the 'classic' observe but parametrized. - -\begin{code} -observeTempl :: String -> Q Exp -observeTempl s = do n <- methodName s - let f = return $ VarE n - s' = stringE s - [| (\x-> fst (gobserve $f DoNotTraceThreadId UnknownId $s' x)) |] -\end{code} - -Generate class definition and class instances for list of types. - -\begin{code} -observedTypes :: String -> [Q Type] -> Q [Dec] -observedTypes s qt = do cd <- (genClassDef s) - ci <- foldM f [] qt - bi <- foldM g [] baseTypes - fi <- (gfunObserver s) - -- li <- (gListObserver s) MF TODO: should we do away with these? - return (cd ++ ci ++ bi ++ fi) - where f d t = do ds <- (gobservableInstance s t) - return (ds ++ d) - g d t = do ds <- (gobservableBaseInstance s t) - return (ds ++ d) - baseTypes = [[t|Int|], [t|Char|], [t|Float|], [t|Bool|]] - - - -\end{code} - -Generate a class definition from a string - -\begin{code} - -genClassDef :: String -> Q [Dec] -genClassDef s = do cn <- className s - mn <- methodName s - nn <- newName "a" - let a = PlainTV nn - tvb = [a] - vt = varT nn - mt <- [t| $vt -> Parent -> $vt |] - let m = SigD mn mt - cd = ClassD [] cn tvb [] [m] - return [cd] - -className :: String -> Q Name -className s = return $ mkName ("Observable" ++ headToUpper s) - -methodName :: String -> Q Name -methodName s = return $ mkName ("observer" ++ headToUpper s) - -headToUpper (c:cs) = toUpper c : cs - -\end{code} - -\begin{code} -gobserverBase :: Q Name -> Q Type -> Q [Dec] -gobserverBase qn t = do n <- qn - c <- gobserverBaseClause qn - return [FunD n [c]] - -gobserverBaseClause :: Q Name -> Q Clause -gobserverBaseClause qn = clause [] (normalB (varE $ mkName "observeBase")) [] -\end{code} - -The generic implementation of the observer function, special cases -for base types and functions. - -\begin{code} -gobserver :: Q Name -> Q Type -> Q [Dec] -gobserver qn t = do n <- qn - cs <- gobserverClauses qn t - return [FunD n cs] - -gobserverClauses :: Q Name -> Q Type -> Q [Clause] -gobserverClauses n qt = do t <- qt - bs <- getBindings qt - case t of - _ -> do cs <- (getConstructors . getName) qt - mapM (gobserverClause t n bs) cs - -gobserverClause :: Type -> Q Name -> TyVarMap -> Con -> Q Clause -gobserverClause t n bs (y@(NormalC name fields)) - = do { vars <- guniqueVariables (length fields) - ; let evars = map varE vars - pvars = map varP vars - c' = varP (mkName "c") - c = varE (mkName "c") - ; clause [conP name pvars, c'] - ( normalB [| send $(shallowShow y) $(observeChildren n t bs y evars) $c |] - ) [] - } -gobserverClause t n bs (InfixC left name right) - = gobserverClause t n bs (NormalC name (left:[right])) -gobserverClause t n bs y = error ("gobserverClause can't handle " ++ show y) -\end{code} - -We also need to do some work to also generate the instance declaration -around the observer method. - -\begin{code} -gobservableInstance :: String -> Q Type -> Q [Dec] -gobservableInstance s qt - = do t <- qt - cn <- className s - let ct = conT cn - n <- case t of - (ForallT tvs _ t') -> [t| $ct $(return t') |] - _ -> [t| $ct $qt |] - m <- gobserver (methodName s) qt - c <- case t of - (ForallT _ c' _) -> return c' - _ -> return [] - return [InstanceD (updateContext cn c) n m] - -#if __GLASGOW_HASKELL__ >= 710 -updateContext :: Name -> [Pred] -> [Pred] -updateContext cn ps = map f ps - where f (AppT (ConT n) ts) -- TH<2.10: f (ClassP n ts) - | nameBase n == "Observable" = (AppT (ConT cn) ts) -- ClassP cn ts - | otherwise = (AppT (ConT n) ts) -- ClassP n ts - f p = p -#else -updateContext :: Name -> [Pred] -> [Pred] -updateContext cn ps = map f ps - where f (ClassP n ts) - | nameBase n == "Observable" = ClassP cn ts - | otherwise = ClassP n ts - f p = p -#endif - -gobservableBaseInstance :: String -> Q Type -> Q [Dec] -gobservableBaseInstance s qt - = do t <- qt - cn <- className s - let ct = conT cn - n <- case t of - (ForallT tvs _ t') -> [t| $ct $(return t') |] - _ -> [t| $ct $qt |] - m <- gobserverBase (methodName s) qt - c <- case t of - (ForallT _ c' _) -> return c' - _ -> return [] - return [InstanceD c n m] - -gobserverFunClause :: Name -> Q Clause -gobserverFunClause n - = do { [f',a'] <- guniqueVariables 2 - ; let vs = [f', mkName "c", a'] - [f, c, a] = map varE vs - pvars = map varP vs - ; clause pvars - (normalB [| let (app,stack) = getStack - $ sendObserveFnPacket stack - ( do a' <- thunk $(varE n) $a - thunk $(varE n) ($f a') - ) $c - in app - |] - ) [] - } - -gobserverFun :: Q Name -> Q [Dec] -gobserverFun qn - = do n <- qn - c <- gobserverFunClause n - cs <- return [c] - return [FunD n cs] - -gfunObserver :: String -> Q [Dec] -gfunObserver s - = do cn <- className s - let ct = conT cn - a = VarT (mkName "a") - b = VarT (mkName "b") - f = return $ AppT (AppT ArrowT a) b -#if __GLASGOW_HASKELL__ >= 710 - p <- return $ AppT (ConT cn) a - q <- return $ AppT (ConT cn) b -#else - let a' = return a - b' = return b - p <- return $ ClassP cn a' - q <- return $ ClassP cn b' -#endif - c <- return [p,q] - n <- [t| $ct $f |] - m <- gobserverFun (methodName s) - return [InstanceD c n m] - -\end{code} - -Creating a shallow representation for types of the Data class. - -\begin{code} -shallowShow :: Con -> ExpQ -shallowShow (NormalC name _) - = stringE (case (nameBase name) of "(,)" -> ","; s -> s) -\end{code} - -Observing the children of Data types of kind *. - -Note how we are forced to add the extra 'vars' argument that should -have the same unique name as the corresponding pattern. - -To implement observeChildren we also define a mapM and compositionM function. -To our knowledge there is no existing work that do this in a generic fashion -with Template Haskell. - -\begin{code} - -isObservable :: TyVarMap -> Type -> Type -> Q Bool --- MF TODO: if s == t then return True else isObservable' bs t -isObservable bs s t = isObservable' bs t - --- MF TODO this is a hack -isObservable' bs (AppT ListT _) = return True - -isObservable' bs (VarT n) = case lookupBinding bs n of - (Just (T t)) -> isObservableT t - (Just (P p)) -> isObservableP p - Nothing -> return False --- isObservable' bs (AppT t _) = isObservable' bs t -isObservable' (n,_) t@(ConT m) = if n == m then return True else isObservableT t -isObservable' bs t = isObservableT t - -isObservableT :: Type -> Q Bool -isObservableT t@(ConT _) = isInstance (mkName "Observable") [t] -isObservableT _ = return False - -isObservableP :: Pred -> Q Bool -#if __GLASGOW_HASKELL__ >= 710 -isObservableP (AppT (ConT n) _) = return $ (nameBase n) == "Observable" -#else -isObservableP (ClassP n _) = return $ (nameBase n) == "Observable" -#endif -isObservableP _ = return False - - -thunkObservable :: Q Name -> TyVarMap -> Type -> Type -> Q Exp -thunkObservable qn bs s t - = do i <- isObservable bs s t - n <- qn - if i then [| thunk $(varE n) |] else [| nothunk |] - -observeChildren :: Q Name -> Type -> TyVarMap -> Con -> [Q Exp] -> Q Exp -observeChildren n t bs = gmapM (thunkObservable n bs t) - -gmapM :: (Type -> Q Exp) -> Con -> [ExpQ] -> ExpQ -gmapM f (NormalC name fields) vars - = m name (reverse fields) (reverse vars) - where m :: Name -> [(Strict,Type)] -> [ExpQ] -> ExpQ - m n _ [] = [| return $(conE n) |] - m n ((_,t):ts) (v:vars) = [| compositionM $(f t) $(m n ts vars) $v |] - - -compositionM :: Monad m => (a -> m b) -> m (b -> c) -> a -> m c -compositionM f g x = do { g' <- g - ; x' <- f x - ; return (g' x') - } -\end{code} - -And we need some helper functions: - -\begin{code} - --- A mapping from typevars to the type they are bound to. - -type TyVarMap = (Name, [(TyVarBndr,TypeOrPred)]) - -data TypeOrPred = T Type | P Pred - - --- MF TODO lookupBinding - -lookupBinding :: TyVarMap -> Name -> Maybe TypeOrPred -lookupBinding (_,[]) _ = Nothing -lookupBinding (r,((b,t):ts)) n - = let m = case b of (PlainTV m ) -> m - (KindedTV m _) ->m - in if (m == n) then Just t else lookupBinding (r,ts) n - --- Given a parametrized type, get a list with typevars and their bindings --- e.g. [(a,Int), (b,Float)] in (MyData a b) Int Float - -getBindings :: Q Type -> Q TyVarMap -getBindings t = do bs <- getBs t - tvs <- (getTvbs . getName) t - pbs <- getPBindings t - n <- getName t - let fromApps = (zip tvs (map T bs)) - fromCxt = (zip tvs (map P pbs)) - return (n, (fromCxt ++ fromApps)) - -getPBindings :: Q Type -> Q [Pred] -getPBindings qt = do t <- qt - case t of (ForallT _ cs _) -> getPBindings' cs - _ -> return [] - -getPBindings' :: [Pred] -> Q [Pred] -getPBindings' [] = return [] -getPBindings' (p:ps) = do pbs <- getPBindings' ps -#if __GLASGOW_HASKELL__ >= 710 - return $ case p of (AppT (ConT n) t) -> p : pbs - _ -> pbs -#else - return $ case p of (ClassP n t) -> p : pbs - _ -> pbs -#endif - --- Given a parametrized type, get a list with its type variables --- e.g. [a,b] in (MyData a b) Int Float - -getTvbs :: Q Name -> Q [TyVarBndr] -getTvbs name = do n <- name - i <- reify n - case i of - TyConI (DataD _ _ tvbs _ _) - -> return tvbs - i - -> error ("getTvbs: can't reify " ++ show i) - --- Given a parametrized type, get a list with the bindings of type variables --- e.g. [Int,Float] in (MyData a b) Int Float - -getBs :: Q Type -> Q [Type] -getBs t = do t' <- t - let t'' = case t' of (ForallT _ _ s) -> s - _ -> t' - return (getBs' t'') - -getBs' :: Type -> [Type] -getBs' (AppT c t) = t : getBs' c -getBs' _ = [] - --- Given a parametrized type, get the name of the type constructor (e.g. Tree in Tree Int) - -getName :: Q Type -> Q Name -getName t = do t' <- t - getName' t' - -getName' :: Type -> Q Name -getName' t = case t of - (ForallT _ _ t'') -> getName' t'' - (AppT t'' _) -> getName' t'' - (ConT name) -> return name - ListT -> return $ mkName "[]" - TupleT _ -> return $ mkName "(,)" - t'' -> error ("getName can't handle " ++ show t'') - --- Given a type, get a list of constructors. - -getConstructors :: Q Name -> Q [Con] -getConstructors name = do {n <- name; TyConI (DataD _ _ _ cs _) <- reify n; return cs} - -guniqueVariables :: Int -> Q [Name] -guniqueVariables n = replicateM n (newName "x") -\end{code} - -%************************************************************************ -%* * -\subsection{Instances} -%* * -%************************************************************************ - - The Haskell Base types - -\begin{code} -instance Observable Int where { observer = observeBase } -instance Observable Bool where { observer = observeBase } -instance Observable Integer where { observer = observeBase } -instance Observable Float where { observer = observeBase } -instance Observable Double where { observer = observeBase } -instance Observable Char where { observer = observeBase } - -instance Observable () where { observer = observeOpaque "()" } - --- utilities for base types. --- The strictness (by using seq) is the same --- as the pattern matching done on other constructors. --- we evalute to WHNF, and not further. - -observeBase :: (Show a) => a -> Parent -> a -observeBase lit cxt = seq lit $ send (show lit) (return lit) cxt - -observeOpaque :: String -> a -> Parent -> a -observeOpaque str val cxt = seq val $ send str (return val) cxt -\end{code} - -The Constructors. - -\begin{code} -instance (Observable a,Observable b) => Observable (a,b) where - observer (a,b) = send "," (return (,) << a << b) - -instance (Observable a,Observable b,Observable c) => Observable (a,b,c) where - observer (a,b,c) = send "," (return (,,) << a << b << c) - -instance (Observable a,Observable b,Observable c,Observable d) - => Observable (a,b,c,d) where - observer (a,b,c,d) = send "," (return (,,,) << a << b << c << d) - -instance (Observable a,Observable b,Observable c,Observable d,Observable e) - => Observable (a,b,c,d,e) where - observer (a,b,c,d,e) = send "," (return (,,,,) << a << b << c << d << e) - -instance (Observable a) => Observable [a] where - observer (a:as) = send ":" (return (:) << a << as) - observer [] = send "[]" (return []) - -instance (Observable a) => Observable (Maybe a) where - observer (Just a) = send "Just" (return Just << a) - observer Nothing = send "Nothing" (return Nothing) - -instance (Observable a,Observable b) => Observable (Either a b) where - observer (Left a) = send "Left" (return Left << a) - observer (Prelude.Right a) = send "Right" (return Prelude.Right << a) -\end{code} - -Arrays. - -\begin{code} -instance (Ix a,Observable a,Observable b) => Observable (Array.Array a b) where - observer arr = send "array" (return Array.array << Array.bounds arr - << Array.assocs arr - ) -\end{code} - -IO monad. - -\begin{code} -instance (Observable a) => Observable (IO a) where - observer fn cxt = - do res <- fn - send "" (return return << res) cxt -\end{code} - - - -The Exception *datatype* (not exceptions themselves!). - -\begin{code} -instance Observable SomeException where - observer e = send (" " ++ show e) (return e) - --- instance Observable ErrorCall where --- observer (ErrorCall a) = send "ErrorCall" (return ErrorCall << a) - - -instance Observable Dynamic where { observer = observeOpaque "" } -\end{code} - - -%************************************************************************ -%* * -\subsection{Classes and Data Definitions} -%* * -%************************************************************************ - -\begin{code} -newtype Observer = O (forall a . (Observable a) => String -> a -> a) - --- defaultObservers :: (Observable a) => String -> (Observer -> a) -> a --- defaultObservers label fn = unsafeWithUniq $ \ node -> --- do { sendEvent node (Parent 0 0) (Observe label ThreadIdUnknown) --- ; let observe' sublabel a --- = unsafeWithUniq $ \ subnode -> --- do { sendEvent subnode (Parent node 0) --- (Observe sublabel ThreadIdUnknown) --- ; return (observer_ observer a (Parent --- { observeParent = subnode --- , observePort = 0 --- })) --- } --- ; return (observer_ observer (fn (O observe')) --- (Parent --- { observeParent = node --- , observePort = 0 --- })) --- } --- defaultFnObservers :: (Observable a, Observable b) --- => String -> (Observer -> a -> b) -> a -> b --- defaultFnObservers label fn arg = unsafeWithUniq $ \ node -> --- do { sendEvent node (Parent 0 0) (Observe label ThreadIdUnknown) --- ; let observe' sublabel a --- = unsafeWithUniq $ \ subnode -> --- do { sendEvent subnode (Parent node 0) --- (Observe sublabel ThreadIdUnknown) --- ; return (observer_ observer a (Parent --- { observeParent = subnode --- , observePort = 0 --- })) --- } --- ; return (observer_ observer (fn (O observe')) --- (Parent --- { observeParent = node --- , observePort = 0 --- }) arg) --- } -\end{code} - - -%************************************************************************ -%* * -\subsection{The ObserveM Monad} -%* * -%************************************************************************ - -The Observer monad, a simple state monad, -for placing numbers on sub-observations. - -\begin{code} -newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) } - -instance Functor ObserverM where - fmap = liftM - -#if __GLASGOW_HASKELL__ >= 710 -instance Applicative ObserverM where - pure = return - (<*>) = ap -#endif - -instance Monad ObserverM where - return a = ObserverM (\ c i -> (a,i)) - fn >>= k = ObserverM (\ c i -> - case runMO fn c i of - (r,i2) -> runMO (k r) c i2 - ) - -thunk :: (a -> Parent -> a) -> a -> ObserverM a -thunk f a = ObserverM $ \ parent port -> - ( observer_ f a (Parent - { observeParent = parent - , observePort = port - }) - , port+1 ) - -gthunk :: (GObservable f) => f a -> ObserverM (f a) -gthunk a = ObserverM $ \ parent port -> - ( gdmobserver_ a (Parent - { observeParent = parent - , observePort = port - }) - , port+1 ) - -nothunk :: a -> ObserverM a -nothunk a = ObserverM $ \ parent port -> - ( observer__ a (Parent - { observeParent = parent - , observePort = port - }) - , port+1 ) - - -(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b --- fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') } -fn << a = gdMapM (thunk observer) fn a - -gdMapM :: (Monad m) - => (a -> m a) -- f - -> m (a -> b) -- data constructor - -> a -- argument - -> m b -- data -gdMapM f c a = do { c' <- c ; a' <- f a ; return (c' a') } - -\end{code} - - -%************************************************************************ -%* * -\subsection{observe and friends} -%* * -%************************************************************************ - -Our principle function and class - -\begin{code} --- | 'observe' observes data structures in flight. --- --- An example of use is --- @ --- map (+1) . observe \"intermeduate\" . map (+2) --- @ --- --- In this example, we observe the value that flows from the producer --- @map (+2)@ to the consumer @map (+1)@. --- --- 'observe' can also observe functions as well a structural values. --- -{-# NOINLINE gobserve #-} -gobserve :: (a->Parent->a) -> TraceThreadId -> Identifier -> String -> a -> (a,Int) -gobserve f tti d name a = generateContext f tti d name a - -{- | -Functions which you suspect of misbehaving are annotated with observe and -should have a cost centre set. The name of the function, the label of the cost -centre and the label given to observe need to be the same. - -Consider the following function: - -@triple x = x + x@ - -This function is annotated as follows: - -> triple y = (observe "triple" (\x -> {# SCC "triple" #} x + x)) y - -To produce computation statements like: - -@triple 3 = 6@ - -To observe a value its type needs to be of class Observable. -We provided instances for many types already. -If you have defined your own type, and want to observe a function -that takes a value of this type as argument or returns a value of this type, -an Observable instance can be derived as follows: - -@ - data MyType = MyNumber Int | MyName String deriving Generic - - instance Observable MyType -@ --} -{-# NOINLINE observe #-} -observe :: (Observable a) => String -> a -> a -observe lbl = fst . (gobserve observer DoNotTraceThreadId UnknownId lbl) - -{-# NOINLINE observeCC #-} -observeCC :: (Observable a) => String -> a -> a -observeCC lbl = fst . (gobserve observer TraceThreadId UnknownId lbl) - -data Identifier = UnknownId | DependsJustOn Int | InSequenceAfter Int - deriving (Show, Eq, Ord) - -{-# NOINLINE observe' #-} -observe' :: (Observable a) => String -> Identifier -> a -> (a,Int) -observe' lbl d x = let (y,i) = (gobserve observer DoNotTraceThreadId d lbl) x - in (y, i) - -{- This gets called before observer, allowing us to mark - - we are entering a, before we do case analysis on - - our object. - -} - -{-# NOINLINE observer_ #-} -observer_ :: (a -> Parent -> a) -> a -> Parent -> a -observer_ f a context = sendEnterPacket f a context - -gdmobserver_ :: (GObservable f) => f a -> Parent -> f a -gdmobserver_ a context = gsendEnterPacket a context - -{-# NOINLINE observer__ #-} -observer__ :: a -> Parent -> a -observer__ a context = sendNoEnterPacket a context - -\end{code} - -\begin{code} -data Parent = Parent - { observeParent :: !Int -- my parent - , observePort :: !Int -- my branch number - } deriving (Show, Read) -\end{code} - - -The functions that output the data. All are dirty. - -\begin{code} -unsafeWithUniq :: (Int -> IO a) -> a -unsafeWithUniq fn - = unsafePerformIO $ do { node <- getUniq - ; fn node - } -\end{code} - -\begin{code} -data TraceThreadId = TraceThreadId | DoNotTraceThreadId - -generateContext :: (a->Parent->a) -> TraceThreadId -> Identifier -> String -> a -> (a,Int) -generateContext f tti d label orig = unsafeWithUniq $ \ node -> - do { t <- myThreadId - ; sendEvent node (Parent 0 0) (Observe label t node d) - ; return (observer_ f orig (Parent - { observeParent = node - , observePort = 0 - }) - , node) - } - where myThreadId = case tti of - DoNotTraceThreadId -> return ThreadIdUnknown - TraceThreadId -> do t <- Concurrent.myThreadId - return (ThreadId t) - -send :: String -> ObserverM a -> Parent -> a -send consLabel fn context = unsafeWithUniq $ \ node -> - do { let (r,portCount) = runMO fn node 0 - ; sendEvent node context (Cons portCount consLabel) - ; return r - } - - -sendEnterPacket :: (a -> Parent -> a) -> a -> Parent -> a -sendEnterPacket f r context = unsafeWithUniq $ \ node -> - do { sendEvent node context Enter - ; ourCatchAllIO (evaluate (f r context)) - (handleExc context) - } - -gsendEnterPacket :: (GObservable f) => f a -> Parent -> f a -gsendEnterPacket r context = unsafeWithUniq $ \ node -> - do { sendEvent node context Enter - ; ourCatchAllIO (evaluate (gdmobserver r context)) - (handleExc context) - } - -sendNoEnterPacket :: a -> Parent -> a -sendNoEnterPacket r context = unsafeWithUniq $ \ node -> - do { sendEvent node context NoEnter - ; ourCatchAllIO (evaluate r) - (handleExc context) - } - -evaluate :: a -> IO a -evaluate a = a `seq` return a - - -sendObserveFnPacket :: CallStack -> ObserverM a -> Parent -> a -sendObserveFnPacket callStack fn context - = unsafeWithUniq $ \ node -> - do { let (r,_) = runMO fn node 0 - ; sendEvent node context (Fun callStack) - ; return r - } -\end{code} - - -%************************************************************************ -%* * -\subsection{Event stream} -%* * -%************************************************************************ - -Trival output functions - -\begin{code} -type Trace = [Event] - -data Event = Event - { portId :: !Int - , parent :: !Parent - , change :: !Change - } - deriving (Show) - -data ThreadId = ThreadIdUnknown | ThreadId Concurrent.ThreadId - deriving (Show,Eq,Ord) - --- MF TODO: Shouldn't we just have the CallStack as part of Observe? -data Change - = Observe !String !ThreadId !Int !Identifier - | Cons !Int !String - | Enter - | NoEnter - | Fun !CallStack - deriving (Show) - -startEventStream :: IO () -startEventStream = writeIORef events [] - -endEventStream :: IO Trace -endEventStream = - do { es <- readIORef events - ; writeIORef events badEvents - ; return es - } - -sendEvent :: Int -> Parent -> Change -> IO () -sendEvent nodeId parent change = - do { nodeId `seq` parent `seq` return () - ; change `seq` return () - ; takeMVar sendSem - ; es <- readIORef events - ; let event = Event nodeId parent change - ; writeIORef events (event `seq` (event : es)) - ; putMVar sendSem () - } - --- local -events :: IORef Trace -events = unsafePerformIO $ newIORef badEvents - -badEvents :: Trace -badEvents = error "Bad Event Stream" - --- use as a trivial semiphore -{-# NOINLINE sendSem #-} -sendSem :: MVar () -sendSem = unsafePerformIO $ newMVar () --- end local -\end{code} - - -%************************************************************************ -%* * -\subsection{unique name supply code} -%* * -%************************************************************************ - -Use the single threaded version - -\begin{code} -type UID = Int - -initUniq :: IO () -initUniq = writeIORef uniq 1 - -getUniq :: IO UID -getUniq - = do { takeMVar uniqSem - ; n <- readIORef uniq - ; writeIORef uniq $! (n + 1) - ; putMVar uniqSem () - ; return n - } - -peepUniq :: IO UID -peepUniq = readIORef uniq - --- locals -{-# NOINLINE uniq #-} -uniq :: IORef UID -uniq = unsafePerformIO $ newIORef 1 - -{-# NOINLINE uniqSem #-} -uniqSem :: MVar () -uniqSem = unsafePerformIO $ newMVar () -\end{code} - - - -%************************************************************************ -%* * -\subsection{Global, initualizers, etc} -%* * -%************************************************************************ - --- \begin{code} --- openObserveGlobal :: IO () --- openObserveGlobal = --- do { initUniq --- ; startEventStream --- } --- --- closeObserveGlobal :: IO Trace --- closeObserveGlobal = --- do { evs <- endEventStream --- ; putStrLn "" --- ; return evs --- } --- \end{code} - -%************************************************************************ -%* * -\subsection{Simulations} -%* * -%************************************************************************ - -Here we provide stubs for the functionally that is not supported -by some compilers, and provide some combinators of various flavors. - -\begin{code} -ourCatchAllIO :: IO a -> (SomeException -> IO a) -> IO a -ourCatchAllIO = Exception.catch - -handleExc :: Parent -> SomeException -> IO a -handleExc context exc = return (send "throw" (return throw << exc) context) -\end{code} - -%************************************************************************ - -% (*>>=) :: Monad m => m a -> (Identifier -> (a -> m b, Int)) -> (m b, Identifier) -% x *>>= f = let (g,i) = f UnknownId in (x >>= g,InSequenceAfter i) -% -% (>>==) :: Monad m => (m a, Identifier) -> (Identifier -> (a -> m b, Int)) -> (m b, Identifier) -% (x,d) >>== f = let (g,i) = f d in (x >>= g,InSequenceAfter i) -% -% (>>=*) :: Monad m => (m a, Identifier) -> (Identifier -> (a -> m b, Int)) -> m b -% (x,d) >>=* f = let (g,i) = f d in x >>= g diff --git a/Debug/Hoed/Stk/Render.hs b/Debug/Hoed/Stk/Render.hs deleted file mode 100644 --- a/Debug/Hoed/Stk/Render.hs +++ /dev/null @@ -1,627 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon, 2014 -{-# OPTIONS_GHC -auto-all #-} - -module Debug.Hoed.Stk.Render -(CompStmt(..) -,renderCompStmts -,byStack -,showWithStack - -,CompGraph(..) -,Vertex(..) -,mkGraph - -,CDS -,eventsToCDS -,rmEntrySet -,simplifyCDSSet -,isRoot -) -where - -import Prelude hiding(lookup) -import Debug.Hoed.Stk.Observe -import Data.List(sort,sortBy,partition,nub) -import Data.Graph.Libgraph -import Data.Array as Array -import Data.Tree.RBTree(RBTree(..),insertOrd,emptyRB,search) - -head' :: String -> [a] -> a -head' msg [] = error msg -head' _ xs = head xs - ------------------------------------------------------------------------- --- Render equations from CDS set - -renderCompStmts :: CDSSet -> [CompStmt] -renderCompStmts = map renderCompStmt - -renderCompStmt :: CDS -> CompStmt -renderCompStmt (CDSNamed name threadId identifier dependsOn set) - = CompStmt name threadId identifier dependsOn equation hstack - where equation = pretty 120 (commas doc) - (doc,stacks)= unzip rendered - rendered = map (renderNamedTop name) output - output = cdssToOutput set - commas [d] = d - commas ds = (foldl (\acc d -> acc <> d <> text ", ") (text "{") ds) <> text "}" - hstack = case stacks of - [] -> [] - (x:_) -> x - - --- renderCompStmt _ = CompStmt "??" ThreadIdUnknown (-1) UnknownId "??" emptyStack - -renderNamedTop :: String -> Output -> (DOC,CallStack) -renderNamedTop name (OutData cds) - = ( nest 2 $ foldl1 (\ a b -> a <> line <> text ", " <> b) (map (renderNamedFn name) pairs) - , callStack - ) - where (pairs',callStack) = findFn [cds] - pairs = (nub . (sort)) pairs' - -- local nub for sorted lists - nub [] = [] - nub (a:a':as) | a == a' = nub (a' : as) - nub (a:as) = a : nub as - ------------------------------------------------------------------------- --- The CompStmt type - -data CompStmt = CompStmt {equLabel :: String, equThreadId :: ThreadId - , equIdentifier :: Int, equDependsOn :: Identifier - , equRes :: String, equStack :: CallStack} - deriving (Ord) - -instance Eq CompStmt where - s1 == s2 = {-# SCC "CompStmt.==" #-} equIdentifier s1 == equIdentifier s2 - -instance Show CompStmt where - show e = equRes e -- ++ " with stack " ++ show (equStack e) - showList eqs eq = unlines (map show eqs) ++ eq - -showWithStack :: [CompStmt] -> String -showWithStack eqs = unlines (map show' eqs) - where show' eq - = equRes eq ++ "\n\tWith call stack: " ++ showStack (equStack eq) - ++ "\n\tNext stack: " ++ showStack (nextStack eq) - ++ "\n\tThread id: " ++ show (equThreadId eq) - ++ "\n\tMy Obs id: " ++ show (equIdentifier eq) - ++ "\n\tDepends on Obs id: " ++ show (equDependsOn eq) - where showStack [] = "[-]" - showStack ss = (foldl (\s' s -> s' ++ s ++ ",") "[" ss) ++ "-]" - --- Compare equations by stack -byStack e1 e2 - = case compareStack (equStack e1) (equStack e2) of - EQ -> compare (equLabel e1) (equLabel e2) - d -> d - -compareStack s1 s2 - | l1 < l2 = LT - | l1 > l2 = GT - | l1 == l2 = c (zip s1 s2) - where l1 = length s1 - l2 = length s2 - c [] = EQ - c ((x,y):ss) = case compare x y of - EQ -> c ss - d -> d - ------------------------------------------------------------------------- --- Stack matching - --- nextStack = case getPushMode of --- Vanilla -> nextStack_vanilla --- Drop -> nextStack_drop --- Truncate -> nextStack_truncate -nextStack = nextStack_truncate - -nextStackVertex (Vertex (c:_) _) = nextStack c -vertexStack (Vertex (c:_) _) = equStack c - --- Always push onto top of stack --- nextStack_vanilla :: CompStmt -> CallStack --- nextStack_vanilla (CompStmt cc _ _ _ _ ccs) = cc:ccs - --- Drop on recursion --- nextStack_drop :: CompStmt -> CallStack --- nextStack_drop (CompStmt cc _ _ _ _ []) = [cc] --- nextStack_drop (CompStmt cc _ _ _ _ ccs) --- = if ccs `contains` cc --- then ccs --- else cc:ccs - --- Remove everything between recursion (e.g. [f,g,f,h] becomes [f,h]) -nextStack_truncate :: CompStmt -> CallStack -nextStack_truncate (CompStmt cc _ _ _ _ []) = [cc] -nextStack_truncate (CompStmt cc _ _ _ _ ccs) - = if ccs `contains` cc - then dropWhile (/= cc) ccs - else cc:ccs - -contains :: CallStack -> String -> Bool -contains ccs cc = filter (== cc) ccs /= [] - --- call :: CallStack -> CallStack -> CallStack --- call sApp sLam = sLam' ++ sApp --- where (sPre,sApp',sLam') = commonPrefix sApp sLam --- --- commonPrefix :: CallStack -> CallStack -> (CallStack, CallStack, CallStack) --- commonPrefix sApp sLam --- = let (sPre,sApp',sLam') = span2 (==) (reverse sApp) (reverse sLam) --- in (sPre, reverse sApp', reverse sLam') --- --- span2 :: (a -> a -> Bool) -> [a] -> [a] -> ([a], [a], [a]) --- span2 f = s f [] --- where s _ pre [] ys = (pre,[],ys) --- s _ pre xs [] = (pre,xs,[]) --- s f pre xs@(x:xs') ys@(y:ys') --- | f x y = s f (x:pre) xs' ys' --- | otherwise = (pre,xs,ys) - ------------------------------------------------------------------------- --- Bags are collections of computation statements with the same stack - -data Bag = Bag {bagStack :: CallStack, bagStmts :: [Vertex]} - -instance Eq Bag where b1 == b2 = {-# SCC "Bag.==" #-} bagStack b1 == bagStack b2 -instance Ord Bag where compare b1 b2 = cmpStk (bagStack b1) (bagStack b2) - -bag :: (Vertex -> CallStack) -> Vertex -> Bag -bag s c = Bag (s c) [c] - -(+++) :: Vertex -> Bag -> Bag -c +++ b = b{bagStmts = c : bagStmts b} - - -mkBags :: (Vertex -> CallStack) -> [Vertex] -> [Bag] -mkBags _ [] = [] -mkBags s cs = mkBags' (bag s fc) [] ocs - - where (fc:ocs) = sortBy (\c1 c2 -> cmpStk (s c1) (s c2)) cs - - mkBags' b bs [] = b:bs - mkBags' b bs (c:cs) - | bagStack b == s c = mkBags' (c +++ b) bs cs - | otherwise = mkBags' (bag s c) (b:bs) cs - ------------------------------------------------------------------------- --- RB trees to speed up computation graph construction - -type Tree = RBTree Bag - -mkTree :: (Vertex -> CallStack) -> [Vertex] -> Tree -mkTree s cs = foldl insertOrd emptyRB (mkBags s cs) - -mkTrees :: [Vertex] -> (Tree,Tree) -mkTrees cs = (mkTree vertexStack cs, mkTree nextStackVertex cs) - -cmpStk :: CallStack -> CallStack -> Ordering -cmpStk [] [] = EQ -cmpStk s1 s2 = case compare (length s1) (length s2) of - EQ -> compare (head s1) (head s2) - ord -> ord - -lookup :: Tree -> CallStack -> [Vertex] -lookup t s = case search (\s b -> cmpStk s (bagStack b)) t s of - (Just b) -> bagStmts b - Nothing -> [] - ------------------------------------------------------------------------- --- Inverse call - -stmts :: Tree -> (CallStack,CallStack) -> [(Vertex,Vertex)] -stmts t (s1,s2) = flattenStmts (lookup t s1, lookup t s2) - -flattenStmts :: ([a],[b]) -> [(a,b)] -flattenStmts (xs,ys) = foldl (\zs x->foldl (\zs' y->(x,y) : zs') zs ys) [] xs - -lacc :: CallStack -> [(CallStack,CallStack)] -lacc = expand . split - -expand :: [([a],[a])] -> [([a],[a])] -expand xs = foldl (\ys x -> ys ++ map (cat $ snd x) (expand' x)) [] xs - - where expand' (xs,[]) = [(xs,[])] - expand' (xs,y:ys) = (xs,y:ys) : expand' (xs,ys) - - cat sApp (xs,ys) = (sApp,xs++ys) - -split :: [a] -> [([a],[a])] -split [] = [] -split (x:xs) = split' [x] xs [] - - where split' _ [] zs = zs - split' xs (y:ys) zs = split' (xs++[y]) ys ((xs,y:ys):zs) - ------------------------------------------------------------------------- --- Computation graphs - -data Vertex = Root | Vertex {equations :: [CompStmt], status :: Judgement} - deriving (Show,Ord) - -instance Eq Vertex where - v1 == v2 = {-# SCC "Vertex.==" #-} v1 === v2 - where Root === Root = True - Root === _ = False - _ === Root = False - (Vertex ss1 j1) === (Vertex ss2 j2) = ss1 == ss2 && j1 == j2 - -type CompGraph = Graph Vertex () - -isRoot Root = True -isRoot _ = False - -pushDeps :: (Tree,Tree) -> [Vertex] -> [Arc Vertex ()] -pushDeps ts cs = concat (map (pushArcs ts) cs) - -pushArcs :: (Tree,Tree) -> Vertex -> [Arc Vertex ()] -pushArcs t p = map (\c -> p ==> c) (pushers t p) - where src ==> tgt = Arc src tgt () - -pushers :: (Tree,Tree) -> Vertex -> [Vertex] -pushers (ts,tn) c = lookup ts (nextStackVertex c) - -callDeps :: (Tree,Tree) -> [Vertex] -> [Arc Vertex ()] -callDeps (_,t) cs = concat (map (callDep t) cs) - -callDep :: Tree -> Vertex -> [Arc Vertex ()] -callDep t c3 = foldl (\as (c2,c1) -> c1 ==> c2 : c2 ==> c3 : as) [] - (concat (map (stmts t) (lacc $ vertexStack c3))) - where src ==> tgt = Arc src tgt () - -mkGraph :: [CompStmt] -> CompGraph -mkGraph cs = (dagify merge) - . addRoot - . nubArcs - $ g - where g :: Graph Vertex () - g = Graph (head' msg vs) vs (pushDeps ts vs ++ callDeps ts vs) - msg = "mkGraph: No computation statements to construct graph from!" - - ts = mkTrees vs - vs = mergeEquivalent cs - - nubArcs :: Graph Vertex () -> Graph Vertex () - nubArcs (Graph r vs as) = Graph r vs (nub as) - - addSequenceDependencies :: Graph CompStmt () -> Graph CompStmt () - addSequenceDependencies (Graph r vs as) = Graph r vs (seqDeps vs ++ as) - seqDeps vs = [Arc v w () |v <- vs, w <- vs, seqDep v w] - seqDep v w = case equDependsOn w of - (InSequenceAfter i) -> i == equIdentifier v - _ -> False - - addRoot :: CompGraph -> CompGraph - addRoot (Graph _ vs as) = - let rs = filter (\(Vertex (s:_) _) -> equStack s == []) vs - es = map (\r -> Root ==> r) rs - in Graph Root (Root : vs) (es ++ as) - - merge :: [Vertex] -> Vertex - merge vs = let v = head' msgvs vs; cs' = map equations vs - in v{equations=foldl (++) [] cs'} - msgvs = "mkGraph.merge: No vertices to merge." - - src ==> tgt = Arc src tgt () - -mergeEquivalent :: [CompStmt] -> [Vertex] -mergeEquivalent [] = [] -mergeEquivalent (c:cs) = mkVertex (c:e) : mergeEquivalent n - where - equivalent x y = equLabel x == equLabel y && equStack x == equStack y - (e,n) = partition (equivalent c) cs - -mkVertex :: [CompStmt] -> Vertex -mkVertex s = Vertex s Unassessed - - --- %************************************************************************ --- %* * --- \subsection{The CDS and converting functions} --- %* * --- %************************************************************************ - - -data CDS = CDSNamed String ThreadId Int Identifier CDSSet - | CDSCons Int String [CDSSet] - | CDSFun Int CDSSet CDSSet CallStack - | CDSEntered Int - | CDSTerminated Int - deriving (Show,Eq,Ord) - -type CDSSet = [CDS] - -eventsToCDS :: [Event] -> CDSSet -eventsToCDS pairs = getChild 0 0 - where - res i = (!) out_arr i - - bnds = (0, length pairs) - - mid_arr :: Array Int [(Int,CDS)] - mid_arr = accumArray (flip (:)) [] bnds - [ (pnode,(pport,res node)) - | (Event node (Parent pnode pport) _) <- pairs - ] - - out_arr = array bnds -- never uses 0 index - [ (node,getNode'' node change) - | (Event node _ change) <- pairs - ] - - getNode'' :: Int -> Change -> CDS - getNode'' node change = - case change of - (Observe str t i d) -> CDSNamed str t i d (getChild node 0) - (Enter) -> CDSEntered node - (NoEnter) -> CDSTerminated node - (Fun str) -> CDSFun node (getChild node 0) (getChild node 1) str - (Cons portc cons) - -> CDSCons node cons - [ getChild node n | n <- [0..(portc-1)]] - - getChild :: Int -> Int -> CDSSet - getChild pnode pport = - [ content - | (pport',content) <- (!) mid_arr pnode - , pport == pport' - ] - -render :: Int -> Bool -> CDS -> DOC -render prec par (CDSCons _ ":" [cds1,cds2]) = - if (par && not needParen) - then doc -- dont use paren (..) because we dont want a grp here! - else paren needParen doc - where - doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <> - renderSet' 4 True cds2 - needParen = prec > 4 -render prec par (CDSCons _ "," cdss) | length cdss > 0 = - nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b) - (map renderSet cdss) <> - text ")") -render prec par (CDSCons _ name cdss) = - paren (length cdss > 0 && prec /= 0) - (nest 2 - (text name <> foldr (<>) nil - [ sep <> renderSet' 10 False cds - | cds <- cdss - ] - ) - ) - -{- renderSet handles the various styles of CDSSet. - -} - -renderSet :: CDSSet -> DOC -renderSet = renderSet' 0 False - -renderSet' :: Int -> Bool -> CDSSet -> DOC -renderSet' _ _ [] = text "_" -renderSet' prec par [cons@(CDSCons {})] = render prec par cons -renderSet' prec par cdss = - nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <> - text ", " <> b) - (map (renderFn caller) pairs) <> - line <> text "}") - - where - (pairs',caller) = findFn cdss - pairs = (nub . sort) pairs' - -- local nub for sorted lists - nub [] = [] - nub (a:a':as) | a == a' = nub (a' : as) - nub (a:as) = a : nub as - -renderFn :: CallStack -> ([CDSSet],CDSSet) -> DOC -renderFn callStack (args, res) - = grp (nest 3 - (text "\\ " <> - foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b) - nil - args <> sep <> - text "-> " <> renderSet' 0 False res - ) - ) - -renderNamedFn :: String -> ([CDSSet],CDSSet) -> DOC -renderNamedFn name (args,res) - = grp (nest 3 - ( text name <> sep - <> foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b) nil args - <> sep <> text "= " <> renderSet' 0 False res - ) - ) - - --- MF TODO: It would be beneficial for performance if we would only save the --- stack once at the top as we already do in the paper and our semantics test code - -findFn :: CDSSet -> ([([CDSSet],CDSSet)], CallStack) -findFn = foldr findFn' ([],[]) - -findFn' (CDSFun _ arg res caller) (rest,_) = - case findFn res of - ([(args',res')],caller') -> -- is this sound? - ((arg : args', res') : rest, caller) - -- or should it be - -- if caller' /= [] && caller' /= caller - -- then error "found two different stacks!" - -- else ((arg : args', res') : rest, caller) - _ -> (([arg], res) : rest, caller) -findFn' other (rest,caller) = (([],[other]) : rest, caller) - -renderTops [] = nil -renderTops tops = line <> foldr (<>) nil (map renderTop tops) - -renderTop :: Output -> DOC -renderTop (OutLabel str set extras) = - nest 2 (text ("-- " ++ str) <> line <> - renderSet set - <> renderTops extras) <> line - -rmEntry :: CDS -> CDS -rmEntry (CDSNamed str t i d set) = CDSNamed str t i d (rmEntrySet set) -rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets) -rmEntry (CDSFun i a b str) = CDSFun i (rmEntrySet a) (rmEntrySet b) str -rmEntry (CDSTerminated i) = CDSTerminated i -rmEntry (CDSEntered i) = error "found bad CDSEntered" - -rmEntrySet = map rmEntry . filter noEntered - where - noEntered (CDSEntered _) = False - noEntered _ = True - -simplifyCDS :: CDS -> CDS -simplifyCDS (CDSNamed str t i d set) = CDSNamed str t i d (simplifyCDSSet set) -simplifyCDS (CDSCons _ "throw" - [[CDSCons _ "ErrorCall" set]] - ) = simplifyCDS (CDSCons 0 "error" set) -simplifyCDS cons@(CDSCons i str sets) = - case spotString [cons] of - Just str | not (null str) -> CDSCons 0 (show str) [] - _ -> CDSCons 0 str (map simplifyCDSSet sets) - -simplifyCDS (CDSFun i a b str) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b) str - -simplifyCDS (CDSTerminated i) = (CDSCons 0 "" []) - -simplifyCDSSet = map simplifyCDS - -spotString :: CDSSet -> Maybe String -spotString [CDSCons _ ":" - [[CDSCons _ str []] - ,rest - ] - ] - = do { ch <- case reads str of - [(ch,"")] -> return ch - _ -> Nothing - ; more <- spotString rest - ; return (ch : more) - } -spotString [CDSCons _ "[]" []] = return [] -spotString other = Nothing - -paren :: Bool -> DOC -> DOC -paren False doc = grp (nest 0 doc) -paren True doc = grp (nest 0 (text "(" <> nest 0 doc <> brk <> text ")")) - -sp :: DOC -sp = text " " - -data Output = OutLabel String CDSSet [Output] - | OutData CDS - deriving (Eq,Ord,Show) - - -commonOutput :: [Output] -> [Output] -commonOutput = sortBy byLabel - where - byLabel (OutLabel lab _ _) (OutLabel lab' _ _) = compare lab lab' - -cdssToOutput :: CDSSet -> [Output] -cdssToOutput = map cdsToOutput - -cdsToOutput (CDSNamed name _ _ _ cdsset) - = OutLabel name res1 res2 - where - res1 = [ cdss | (OutData cdss) <- res ] - res2 = [ out | out@(OutLabel {}) <- res ] - res = cdssToOutput cdsset -cdsToOutput cons@(CDSCons {}) = OutData cons -cdsToOutput fn@(CDSFun {}) = OutData fn - --- %************************************************************************ --- %* * --- \subsection{A Pretty Printer} --- %* * --- %************************************************************************ - --- This pretty printer is based on Wadler's pretty printer. - -data DOC = NIL -- nil - | DOC :<> DOC -- beside - | NEST Int DOC - | TEXT String - | LINE -- always "\n" - | SEP -- " " or "\n" - | BREAK -- "" or "\n" - | DOC :<|> DOC -- choose one - deriving (Eq,Show) -data Doc = Nil - | Text Int String Doc - | Line Int Int Doc - deriving (Show,Eq) - - -mkText :: String -> Doc -> Doc -mkText s d = Text (toplen d + length s) s d - -mkLine :: Int -> Doc -> Doc -mkLine i d = Line (toplen d + i) i d - -toplen :: Doc -> Int -toplen Nil = 0 -toplen (Text w s x) = w -toplen (Line w s x) = 0 - -nil = NIL -x <> y = x :<> y -nest i x = NEST i x -text s = TEXT s -line = LINE -sep = SEP -brk = BREAK - -fold x = grp (brk <> x) - -grp :: DOC -> DOC -grp x = - case flatten x of - Just x' -> x' :<|> x - Nothing -> x - -flatten :: DOC -> Maybe DOC -flatten NIL = return NIL -flatten (x :<> y) = - do x' <- flatten x - y' <- flatten y - return (x' :<> y') -flatten (NEST i x) = - do x' <- flatten x - return (NEST i x') -flatten (TEXT s) = return (TEXT s) -flatten LINE = Nothing -- abort -flatten SEP = return (TEXT " ") -- SEP is space -flatten BREAK = return NIL -- BREAK is nil -flatten (x :<|> y) = flatten x - -layout :: Doc -> String -layout Nil = "" -layout (Text _ s x) = s ++ layout x -layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x - -best w k doc = be w k [(0,doc)] - -be :: Int -> Int -> [(Int,DOC)] -> Doc -be w k [] = Nil -be w k ((i,NIL):z) = be w k z -be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z) -be w k ((i,NEST j x):z) = be w k ((k+j,x):z) -be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z -be w k ((i,LINE):z) = i `mkLine` be w i z -be w k ((i,SEP):z) = i `mkLine` be w i z -be w k ((i,BREAK):z) = i `mkLine` be w i z -be w k ((i,x :<|> y):z) = better w k - (be w k ((i,x):z)) - (be w k ((i,y):z)) - -better :: Int -> Int -> Doc -> Doc -> Doc -better w k x y = if (w-k) >= toplen x then x else y - -pretty :: Int -> DOC -> String -pretty w x = layout (best w 0 x) diff --git a/Debug/NoHoed.hs b/Debug/NoHoed.hs new file mode 100644 --- /dev/null +++ b/Debug/NoHoed.hs @@ -0,0 +1,128 @@ +{-| +Module : Debug.Hoed.Notrace +Description : Lighweight algorithmic debugging based on observing intermediate values. +Copyright : (c) 2016 Maarten Faddegon +License : BSD3 +Maintainer : hoed@maartenfaddegon.nl +Stability : experimental +Portability : POSIX + +Hoed is a tracer and debugger for the programming language Haskell. + +This is a drop-in replacement of the Debug.Hoed.Pure or Debug.Hoed.Stk modules and disables tracing (all functions are variations of id). + +Read more about Hoed on its project homepage . + +Papers on the theory behind Hoed can be obtained via . + +I am keen to hear about your experience with Hoed: where did you find it useful and where would you like to see improvement? You can send me an e-mail at hoed@maartenfaddegon.nl, or use the github issue tracker . +-} + +{-# LANGUAGE DefaultSignatures, CPP #-} + +module Debug.NoHoed +( observe +, runO +, printO +, testO +, observeBase +, Observable(..) +, Parent(..) +, Generic(..) +, send +, ObserverM(..) +, (<<) +) where +import GHC.Generics +import System.IO.Unsafe +import Control.Monad + +observe :: String -> a -> a +observe _ = id + +runO :: IO a -> IO () +runO program = do + program + return () + +printO :: (Show a) => a -> IO () +printO expr = print expr + +testO :: Show a => (a->Bool) -> a -> IO () +testO p x = putStrLn $ if (p x) then "Passed 1 test." + else " *** Failed! Falsifiable: " ++ show x + +data Parent = Parent +class Observable a where + observer :: a -> Parent -> a + default observer :: (Generic a) => a -> Parent -> a + observer x _ = x + + constrain :: a -> a -> a + default constrain :: (Generic a) => a -> a -> a + constrain x _ = x + +observeBase :: a -> Parent -> a +observeBase x _ = x + +constrainBase :: a -> a -> a +constrainBase x _ = x + +newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) } + +instance Functor ObserverM where + fmap = liftM + +#if __GLASGOW_HASKELL__ >= 710 +instance Applicative ObserverM where + pure = return + (<*>) = ap +#endif + +instance Monad ObserverM where + return a = ObserverM (\ c i -> (a,i)) + fn >>= k = ObserverM (\ c i -> + case runMO fn c i of + (r,i2) -> runMO (k r) c i2 + ) + +(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b +fn << a = do {fn' <- fn; return (fn' a)} + +send :: String -> ObserverM a -> Parent -> a +send _ fn context = + unsafePerformIO $ do { let (r,portCount) = runMO fn 0 0 + ; return r + } + +instance Observable Int where + observer = observeBase + constrain = constrainBase + +instance Observable Bool where + observer = observeBase + constrain = constrainBase + +instance Observable Integer where + observer = observeBase + constrain = constrainBase + +instance Observable Float where + observer = observeBase + constrain = constrainBase + +instance Observable Double where + observer = observeBase + constrain = constrainBase + +instance Observable Char where + observer = observeBase + constrain = constrainBase + +instance Observable () where + observer = observeBase + constrain = constrainBase + +instance (Observable a) => Observable [a] where + observer = observeBase + constrain = constrainBase diff --git a/Hoed.cabal b/Hoed.cabal --- a/Hoed.cabal +++ b/Hoed.cabal @@ -1,1128 +1,48 @@ name: Hoed -version: 0.3.6 -synopsis: Lightweight algorithmic debugging. -description: - Hoed is a tracer and debugger for the programming language Haskell. - . - To locate a defect with Hoed you annotate suspected functions and compile as usual. Then you run your program, information about the annotated functions is collected. Finally you connect to a debugging session using a webbrowser. - . - Hoed comes in two flavours: Hoed.Pure and Hoed.Stk. Hoed.Stk uses the cost-centre stacks of the GHC profiling environment to construct the information needed for debugging. Hoed.Pure is recommended over Hoed.Stk: to debug your program with Hoed.Pure you can optimize your program and do not need to enable profiling. - . -homepage: https://wiki.haskell.org/Hoed -license: BSD3 -license-file: LICENSE -author: Maarten Faddegon -maintainer: hoed@maartenfaddegon.nl -copyright: (c) 2000 Andy Gill, (c) 2010 University of Kansas, (c) 2013-2016 Maarten Faddegon -category: Debug, Trace -build-type: Simple -cabal-version: >=1.10 -extra-source-files: changelog, README.md, configure.Demo, configure.Generic, configure.Profiling, configure.Prop, configure.Pure, configure.Stk, run, test.Generic, test.Pure, test.Stk -data-files: img/*.png, img/*.gif - - -flag buildPropExamples - description: Build example executables. - default: False - -flag buildExamples - description: Build example executables. - default: False - -flag validatePure - description: Build test cases to validate Hoed-pure. - default: False - -flag validateStk - description: Build test cases to validate Hoed-stk. - default: False - -flag validateGeneric - description: Build test cases to validate deriving Observable for Generic types. - default: False - -flag validateProp - description: Build test cases to validate deriving judgements with properties. - default: False - -Source-repository head - type: git - location: git://github.com/MaartenFaddegon/Hoed.git - -library - exposed-modules: Debug.Hoed.Stk - , Debug.Hoed.Pure - , Debug.Hoed.NoTrace - other-modules: Debug.Hoed.Stk.Observe - , Debug.Hoed.Stk.Render - , Debug.Hoed.Stk.DemoGUI - , Debug.Hoed.Pure.Observe - , Debug.Hoed.Pure.EventForest - , Debug.Hoed.Pure.CompTree - , Debug.Hoed.Pure.Render - , Debug.Hoed.Pure.DemoGUI - , Debug.Hoed.Pure.Prop - , Debug.Hoed.Pure.Serialize - , Paths_Hoed - build-depends: base >= 4 && <5 - , template-haskell - , array, containers - , process - , threepenny-gui == 0.6.0.5 - , filepath - , libgraph == 1.11 - , RBTree == 0.0.5 - , regex-posix - , mtl - , directory - , FPretty - , cereal, bytestring - , time - default-language: Haskell2010 - -- Enable to get some extra warnings. - -- ghc-options: -fwarn-unused-binds - - -- Enable to create a file .Hoed/Transcript that lists all steps taken to construct a - -- computation tree from the list of events. - -- cpp-options: -DTRANSCRIPT - ---------------------------------------------------------------------------- --- --- A list of example-programs that bind to a debugging session after the --- program terminates. After running 'cabal build' these are available to --- experiment with through 'sh run'. --- ---------------------------------------------------------------------------- - -Executable hoed-examples-Raincat - if flag(buildExamples) - build-depends: base >= 3 && < 5, - containers, - extensible-exceptions, - mtl, - random, - time, - GLUT, - OpenGL, - SDL, - SDL-image, - SDL-mixer, - Hoed - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/Raincat/src - default-language: Haskell2010 - -Executable hoed-examples-FPretty_indents_too_much - if flag(buildExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - , containers - , deepseq - , array - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/FPretty - default-language: Haskell2010 - -Executable hoed-examples-FPretty_indents_too_much__CC - if flag(buildExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - , containers - , deepseq - , array - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/FPretty__CC - default-language: Haskell2010 - --- Executable hoed-examples-FPretty_indents_too_much__with_properties --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- , containers --- , deepseq --- , array --- , QuickCheck --- , mtl --- else --- buildable: False --- main-is: Main.hs --- hs-source-dirs: examples/FPretty__with_properties --- default-language: Haskell2010 - -Executable hoed-examples-Stern-Brocot - if flag(buildExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - , containers - , deepseq - , array - else - buildable: False - main-is: SternBrocot.lhs - hs-source-dirs: examples/ - default-language: Haskell2010 - -Executable hoed-examples-Queens_v1__with_properties - -- if flag(buildExamples) || - if flag (buildPropExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - , containers - , deepseq - , array - , QuickCheck - , mtl - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/Queens__with_properties - default-language: Haskell2010 - -Executable hoed-examples-Queens_v2__with_properties - if flag(buildPropExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - , containers - , deepseq - , array - , QuickCheck - , mtl - else - buildable: False - main-is: Main2.hs - hs-source-dirs: examples/Queens__with_properties - default-language: Haskell2010 - -Executable hoed-examples-Queens_v3__with_properties - if flag(buildPropExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - , containers - , deepseq - , array - , QuickCheck - , mtl - else - buildable: False - main-is: Main3.hs - hs-source-dirs: examples/Queens__with_properties - default-language: Haskell2010 - -Executable hoed-examples-Queens_v4_defect_in_filter__with_properties - if flag(buildPropExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - , containers - , deepseq - , array - , QuickCheck - , mtl - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/Queens_defective_filter__with_properties - default-language: Haskell2010 - -Executable hoed-examples-filter__with_properties - if flag(buildPropExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - , containers - , deepseq - , array - , QuickCheck - , mtl - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/filter__with_properties - default-language: Haskell2010 - - -Executable hoed-examples-Rot13 - if flag(buildExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - else - buildable: False - main-is: Rot13.hs - hs-source-dirs: examples - default-language: Haskell2010 - -Executable hoed-examples-Salary - if flag(buildExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - else - buildable: False - main-is: Salary.hs - hs-source-dirs: examples - default-language: Haskell2010 - -Executable hoed-examples-ZLang_Defect-1 - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, threepenny-gui == 0.6.0.5, filepath, QuickCheck, mtl, monad-loops, transformers, containers, parsec, indents, adjunctions - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/ZLang/1 - default-language: Haskell2010 - -Executable hoed-examples-ZLang_Defect-2 - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, threepenny-gui == 0.6.0.5, filepath, QuickCheck, mtl, monad-loops, transformers, containers, parsec, indents, adjunctions - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/ZLang/2 - default-language: Haskell2010 - -Executable hoed-examples-ZLang_Defect-3 - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, threepenny-gui == 0.6.0.5, filepath, QuickCheck, mtl, monad-loops, transformers, containers, parsec, indents, adjunctions - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/ZLang/3 - default-language: Haskell2010 - -Executable hoed-examples-Nub-defective-sort__with_properties - if flag(buildPropExamples) - build-depends: base >= 4 && < 5, Hoed, threepenny-gui == 0.6.0.5, filepath, QuickCheck - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/Nubsort - default-language: Haskell2010 - -Executable hoed-examples-Insertion_Sort_elements_disappear - if flag(buildExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - else - buildable: False - main-is: Insertion_Sort_elements_disappear.hs - hs-source-dirs: examples - default-language: Haskell2010 - -Executable hoed-examples-XMonad_changing_focus_duplicates_windows - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/XMonad_changing_focus_duplicates_windows - default-language: Haskell2010 - -Executable hoed-examples-XMonad_changing_focus_duplicates_windows__test_only - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/XMonad_changing_focus_duplicates_windows__test_only - default-language: Haskell2010 - -Executable hoed-examples-XMonad_changing_focus_duplicates_windows__CC - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/XMonad_changing_focus_duplicates_windows__CC - default-language: Haskell2010 - -Executable hoed-examples-XMonad_changing_focus_duplicates_windows__with_properties - --if flag(buildExamples) - if flag (buildPropExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/XMonad_changing_focus_duplicates_windows__using_properties - default-language: Haskell2010 - -Executable hoed-examples-SummerSchool_compiler_does_not_terminate - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory, - array - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/afp02Exercises/Compiler/ - default-language: Haskell2010 - -Executable hoed-examples-SummerSchool_compiler_does_not_terminate__with_properties - if flag(buildPropExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory, - array,QuickCheck - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/afp02Exercises/Compiler__with_properties/ - default-language: Haskell2010 - -Executable hoed-examples-CNF_unsound_de_Morgan__with_properties - if flag(buildPropExamples) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/CNF_unsound_demorgan__with_properties/ - default-language: Haskell2010 - -Executable hoed-examples-Digraph_not_data_invariant__with_properties - if flag(buildPropExamples) - build-depends: base >= 4 && < 5, Hoed, lazysmallcheck - else - buildable: False - main-is: Main.hs - hs-source-dirs: examples/Digraph_not_data_invariant__with_properties/ - default-language: Haskell2010 - -Executable hoed-examples-Simple_higher-order_function - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory, - array - else - buildable: False - main-is: SimpleHO.hs - hs-source-dirs: examples/ - default-language: Haskell2010 - --- MF TODO: add source to repository and re-enable this again --- Executable hoed-examples-Exception --- if flag(buildExamples) --- build-depends: base >= 4 && < 5, Hoed, --- X11>=1.5 && < 1.7, mtl, unix, --- utf8-string, --- extensible-exceptions, random, --- containers, filepath, process, directory, --- array --- else --- buildable: False --- main-is: Exception.hs --- hs-source-dirs: examples/ --- default-language: Haskell2010 - -Executable hoed-examples-Parity_test - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory, - array - else - buildable: False - main-is: Parity.hs - hs-source-dirs: examples/ - default-language: Haskell2010 - -Executable hoed-examples-Expression_simplifier - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory, - array - else - buildable: False - main-is: Main1.hs - hs-source-dirs: examples/ExpressionSimplifier - default-language: Haskell2010 - -Executable hoed-examples-Expression_simplifier__with_properties - if flag(buildExamples) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory, - array - else - buildable: False - main-is: Main2.hs - hs-source-dirs: examples/ExpressionSimplifier - default-language: Haskell2010 - - - --- --- --- Executable hoed-examples-Foldl --- if flag(buildExamples) --- build-depends: base >= 4.8 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: Foldl.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-HeadOnEmpty1 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: HeadOnEmpty.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-HeadOnEmpty2 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: HeadOnEmpty2.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- -- Executable hoed-examples-IOException --- -- build-depends: base >= 4 && < 5 --- -- , Hoed --- -- , threepenny-gui --- -- , filepath --- -- , hood --- -- main-is: IOException.hs --- -- hs-source-dirs: examples --- -- default-language: Haskell2010 --- -- ghc-options: -O0 --- --- Executable hoed-examples-IndirectRecursion --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: IndirectRecursion.lhs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-Pretty --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- , array --- else --- buildable: False --- main-is: Pretty.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-Example1 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: Example1.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- -- Executable hoed-examples-Example2 --- -- build-depends: base >= 4 && < 5 --- -- , Hoed --- -- , threepenny-gui --- -- , filepath --- -- main-is: Example2.hs --- -- hs-source-dirs: examples --- -- default-language: Haskell2010 --- --- Executable hoed-examples-Example3 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: Example3.lhs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-Example4 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: Example4.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-Insort1 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: Insort.lhs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- Executable hoed-examples-DoublingServer1 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- , network --- else --- buildable: False --- main-is: DoublingServer.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-DoublingServer2 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- , network --- else --- buildable: False --- main-is: DoublingServer2.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-DoublingServer3 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- , network --- else --- buildable: False --- main-is: DoublingServer3.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-DoublingServer4 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- , network --- else --- buildable: False --- main-is: DoublingServer4.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-DoublingServer5 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- , network --- else --- buildable: False --- main-is: DoublingServer5.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-Hashmap --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- , array --- else --- buildable: False --- main-is: Hashmap.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-Responsibility --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- , array --- else --- buildable: False --- main-is: Responsibility.lhs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-TightRope1 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: TightRope.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-TightRope2 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: TightRope2.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-TightRope3 --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: TightRope3.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 --- --- Executable hoed-examples-AskName --- if flag(buildExamples) --- build-depends: base >= 4 && < 5 --- , Hoed --- , threepenny-gui --- , filepath --- else --- buildable: False --- main-is: AskName.hs --- hs-source-dirs: examples --- default-language: Haskell2010 --- ghc-options: -O0 - ---------------------------------------------------------------------------- --- --- A set of tests that instead of binding to a debugging session write the --- resulting computation graph to file; with the test.* scripts these are --- validated against references. --- ---------------------------------------------------------------------------- - -Executable hoed-tests-Prop-t0 - if flag(validateProp) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: Main.hs - hs-source-dirs: tests/Prop/t0 - default-language: Haskell2010 - - -Executable hoed-tests-Prop-t1 - if flag(validateProp) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: Main.hs - hs-source-dirs: tests/Prop/t1 - default-language: Haskell2010 - -Executable hoed-tests-Prop-t2 - if flag(validateProp) - build-depends: base >= 4 && < 5, Hoed, lazysmallcheck - else - buildable: False - main-is: Main.hs - hs-source-dirs: tests/Prop/t2 - default-language: Haskell2010 - -Executable hoed-tests-Prop-t3 - if flag(validateProp) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory - else - buildable: False - main-is: Main.hs - hs-source-dirs: tests/Prop/t3 - default-language: Haskell2010 - -Executable hoed-tests-Prop-t4 - if flag(validateProp) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory - else - buildable: False - main-is: Main.hs - hs-source-dirs: tests/Prop/t4 - default-language: Haskell2010 - -Executable hoed-tests-Prop-t5 - if flag(validateProp) - build-depends: base >= 4 && < 5, Hoed, - X11>=1.5 && < 1.7, mtl, unix, - utf8-string, - extensible-exceptions, random, - containers, filepath, process, directory, - QuickCheck - else - buildable: False - main-is: Main.hs - hs-source-dirs: tests/Prop/t5 - default-language: Haskell2010 - ---------------------------------------------------------------------------- --- Validate derivation of Observable and ParEq for Generic types --- ---------------------------------------------------------------------------- - - -Executable hoed-tests-ParEq - if flag(validateGeneric) - build-depends: base >= 4 && <5 - , template-haskell - , array, containers - , process - , threepenny-gui == 0.6.0.5 - , filepath - , libgraph == 1.11 - , RBTree == 0.0.5 - , regex-posix - , mtl - , directory - , FPretty - , cereal - , bytestring - else - buildable: False - main-is: Debug/Hoed/Pure/TestParEq.hs - default-language: Haskell2010 - - - -Executable hoed-tests-Generic-r0 - if flag(validateGeneric) - build-depends: base >= 4 && < 5 - , Hoed - else - buildable: False - main-is: r0.hs - hs-source-dirs: tests/Generic - default-language: Haskell2010 - -Executable hoed-tests-Generic-t0 - if flag(validateGeneric) - build-depends: base >= 4 && < 5 - , Hoed - else - buildable: False - main-is: t0.hs - hs-source-dirs: tests/Generic - default-language: Haskell2010 - -Executable hoed-tests-Generic-r1 - if flag(validateGeneric) - build-depends: base >= 4 && < 5 - , Hoed - else - buildable: False - main-is: r1.hs - hs-source-dirs: tests/Generic - default-language: Haskell2010 - -Executable hoed-tests-Generic-t1 - if flag(validateGeneric) - build-depends: base >= 4 && < 5 - , Hoed - else - buildable: False - main-is: t1.hs - hs-source-dirs: tests/Generic - default-language: Haskell2010 - -Executable hoed-tests-Generic-r2 - if flag(validateGeneric) - build-depends: base >= 4 && < 5 - , Hoed - else - buildable: False - main-is: r2.hs - hs-source-dirs: tests/Generic - default-language: Haskell2010 - -Executable hoed-tests-Generic-t2 - if flag(validateGeneric) - build-depends: base >= 4 && < 5 - , Hoed - else - buildable: False - main-is: t2.hs - hs-source-dirs: tests/Generic - default-language: Haskell2010 - -Executable hoed-tests-Generic-r3 - if flag(validateGeneric) - build-depends: base >= 4 && < 5 - , Hoed - else - buildable: False - main-is: r3.hs - hs-source-dirs: tests/Generic - default-language: Haskell2010 - -Executable hoed-tests-Generic-t3 - if flag(validateGeneric) - build-depends: base >= 4 && < 5 - , Hoed - else - buildable: False - main-is: t3.hs - hs-source-dirs: tests/Generic - default-language: Haskell2010 - ---------------------------------------------------------------------------- - -Executable hoed-tests-Pure-t1 - if flag(validatePure) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: t1.hs - hs-source-dirs: tests/Pure - default-language: Haskell2010 - -Executable hoed-tests-Pure-t2 - if flag(validatePure) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: t2.hs - hs-source-dirs: tests/Pure - default-language: Haskell2010 - -Executable hoed-tests-Pure-t3 - if flag(validatePure) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: t3.hs - hs-source-dirs: tests/Pure - default-language: Haskell2010 - -Executable hoed-tests-Pure-t4 - if flag(validatePure) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: t4.hs - hs-source-dirs: tests/Pure - default-language: Haskell2010 - -Executable hoed-tests-Pure-t5 - if flag(validatePure) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: t5.hs - hs-source-dirs: tests/Pure - default-language: Haskell2010 - -Executable hoed-tests-Pure-t6 - if flag(validatePure) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: t6.hs - hs-source-dirs: tests/Pure - default-language: Haskell2010 - -Executable hoed-tests-Pure-t7 - if flag(validatePure) - build-depends: base >= 4 && < 5, Hoed - else - buildable: False - main-is: t7.hs - hs-source-dirs: tests/Pure - default-language: Haskell2010 - ---------------------------------------------------------------------------- - -Executable hoed-tests-Stk-DoublingServer - if flag(validateStk) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - , network - else - buildable: False - main-is: DoublingServer.hs - hs-source-dirs: tests/Stk - default-language: Haskell2010 - ghc-options: -O0 - -Executable hoed-tests-Stk-Insort2 - if flag(validateStk) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - else - buildable: False - main-is: Insort2.hs - hs-source-dirs: tests/Stk - default-language: Haskell2010 - ghc-options: -O0 - -Executable hoed-tests-Stk-Example1 - if flag(validateStk) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - else - buildable: False - main-is: Example1.hs - hs-source-dirs: tests/Stk - default-language: Haskell2010 - ghc-options: -O0 - -Executable hoed-tests-Stk-Example3 - if flag(validateStk) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - else - buildable: False - main-is: Example3.lhs - hs-source-dirs: tests/Stk - default-language: Haskell2010 - ghc-options: -O0 - -Executable hoed-tests-Stk-Example4 - if flag(validateStk) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - else - buildable: False - main-is: Example4.hs - hs-source-dirs: tests/Stk - default-language: Haskell2010 - ghc-options: -O0 - -Executable hoed-tests-Stk-IndirectRecursion - if flag(validateStk) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui == 0.6.0.5 - , filepath - else - buildable: False - main-is: IndirectRecursion.lhs - hs-source-dirs: tests/Stk - default-language: Haskell2010 - ghc-options: -O0 +version: 0.4.0 +synopsis: Lightweight algorithmic debugging. +description: + Hoed is a tracer and debugger for the programming language Haskell. + . + To locate a defect with Hoed you annotate suspected functions and compile as usual. Then you run your program, information about the annotated functions is collected. Finally you connect to a debugging session using a webbrowser. + . +homepage: https://wiki.haskell.org/Hoed +license: BSD3 +license-file: LICENSE +author: Maarten Faddegon +maintainer: hoed@maartenfaddegon.nl +copyright: (c) 2000 Andy Gill, (c) 2010 University of Kansas, (c) 2013-2017 Maarten Faddegon +category: Debug, Trace +build-type: Simple +cabal-version: >=1.10 +extra-source-files: changelog, README.md, configure.Demo, configure.Generic, configure.Profiling, configure.Prop, configure.Pure, run, test.Generic, test.Pure +data-files: img/*.png, img/*.gif + +source-repository head + type: git + location: https://github.com/MaartenFaddegon/Hoed.git + +library + exposed-modules: Debug.Hoed + , Debug.NoHoed + other-modules: Debug.Hoed.Observe + , Debug.Hoed.EventForest + , Debug.Hoed.CompTree + , Debug.Hoed.Render + , Debug.Hoed.ReadLine + , Debug.Hoed.Console + , Debug.Hoed.Prop + , Debug.Hoed.Serialize + , Text.PrettyPrint.FPretty + , Paths_Hoed + build-depends: base >= 4 && <5 + , array, containers + , process + , filepath + , libgraph == 1.14 + , regex-posix + , mtl + , directory + , cereal, bytestring + , time + default-language: Haskell2010 diff --git a/Text/PrettyPrint/FPretty.hs b/Text/PrettyPrint/FPretty.hs new file mode 100644 --- /dev/null +++ b/Text/PrettyPrint/FPretty.hs @@ -0,0 +1,429 @@ +{-# LANGUAGE Safe, CPP #-} + +-- | +-- Module : Text.PrettyPrint.FPretty +-- License : BSD3 +-- Maintainer : Olaf Chitil +-- Portability : portable +-- +-- Fast pretty-printing library +-- +-- A pretty printer turns a tree structure into indented text, such that the +-- indentation reflects the tree structure. To minimise the number of lines, +-- substructures are put on a single line as far as possible within the given +-- line-width limit. +-- +-- An pretty-printed example with 35 characters line-width: +-- +-- > if True +-- > then if True then True else True +-- > else +-- > if False +-- > then False +-- > else False +-- +-- To obtain the above the user of a library only has to convert their tree +-- structure into a document of type 'Doc'. +-- +-- > data Exp = ETrue | EFalse | If Exp Exp Exp +-- > +-- > toDoc :: Exp -> Doc +-- > toDoc ETrue = text "True" +-- > toDoc EFalse = text "False" +-- > toDoc (If e1 e2 e3) = +-- > group (nest 3 ( +-- > group (nest 3 (text "if" <> line <> toDoc e1)) <> line <> +-- > group (nest 3 (text "then" <> line <> toDoc e2)) <> line <> +-- > group (nest 3 (text "else" <> line <> toDoc e3)))) +-- +-- A document represents a set of layouts. The function 'pretty' then takes +-- a desired maximal printing width and a document and selects the layout that fits +-- best. +-- +-- Another example filling lines with elements of a list: +-- +-- > list2Doc :: Show a => [a] -> Doc +-- > list2Doc xs = text "[" <> go xs <> text "]" +-- > where +-- > go [] = empty +-- > go [x] = text (show x) +-- > go (x:y:ys) = text (show x) text ", " <> go (y:ys) +-- > +-- > main = putStrLn (pretty 40 (list2Doc [1..20])) +-- +-- The output is +-- +-- > [1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 +-- > , 11 , 12 , 13 , 14 , 15 , 16 , 17 , 18 +-- > , 19 , 20] +-- +-- FPretty is an implementation of the simple combinators designed by Phil Wadler. +-- The library uses a single associative combinator '<>' to concatenate documents with +-- 'empty' as identity. There is a primitive document for potential line breaks, i.e., +-- its two layouts are both a line break and a space. The 'group' combinator then +-- enforces that all potential line breaks within a document must be layouted in the +-- same way, i.e. either line breaks or spaces. +-- +-- The time complexity is linear in the output size. +-- In contrast, all other pretty printing libraries +-- (original Phil Wadler, PPrint by Leijen, Hughes / Peyton Jones) +-- use more or less backtracking, and their speed depends unpredictably on the +-- desired output width. +-- +-- Also FPretty provides both relative and absolute indentation via +-- nest and align, whereas HughesPJ provides only relative indentation. +-- +-- FPretty uses far less space than other pretty printing libraries for large documents. +-- It does require space linear in the nesting depth of nest/align combinators; +-- however, having these deeply nested leads to a bad layout anyway. +-- +-- Unlike other libraries, FPretty does not provide several rendering modes, +-- but could be extended to do so. +-- +-- The combinators are a subset of those of PPrint and are similar to HughesPJ +-- to make moving from one library to the other as painless as possible. +-- +-- For more implementation notes see or +-- Doitse Swierstra and Olaf Chitil: Linear, bounded, functional pretty-printing. +-- Journal of Functional Programming, 19(1):1-16, January 2009. + +-- The implementation could be speeded up further by specialisation of the interpreter +-- for dequeues of size 0, 1 and >1. + +module Text.PrettyPrint.FPretty + ( + -- * The type of documents + Doc + -- * Pretty printing + ,pretty + -- * Basic documents + ,empty,text + -- * Basic documents with several layouts + ,line,linebreak,softline,softbreak + -- * Combining two documents + -- ** The base binary combinator + ,(<>) + -- ** Derived binary combinators + ,(<+>),(<$>),(<$$>),(),() + -- * Modifying the layouts of one document + ,group,nest,align,hang + -- * Combining many documents + ,hsep,vsep,fillSep,sep,hcat,vcat,fillCat,cat) where + +#if __GLASGOW_HASKELL__ >= 710 +-- The base libraries from GHC 7.10 onwards export <$> as synonym for fmap. +import Prelude hiding ((<$>)) +#endif + +import Data.Maybe (fromJust) +import Data.Sequence as Dequeue (Seq, (<|), viewl, viewr, ViewL(..), ViewR(..)) +import qualified Data.Sequence as Dequeue (empty) + -- Originally used Banker's dequeue from Okasaki's book + -- on Functional Data Structures. + -- Efficiency probably similar, but Data.Sequence is part of the standard Haskell + -- libraries. + +infixr 6 <>,<+> +infixr 5 <$>,<$$>,, + +---------------------- +-- derived combinators + +-- | A space, if the following still fits on the current line, otherwise newline. +softline :: Doc +softline = group line + +-- | Nothing, if the following still fits on the current line, otherwise newline. +softbreak :: Doc +softbreak = group linebreak + +-- | Increase identation relative to the *current* column. +hang :: Int -> Doc -> Doc +hang i x = align (nest i x) + +-- | Combine with a space in between. +(<+>) :: Doc -> Doc -> Doc +dl <+> dr = dl <> text " " <> dr + +-- | Combine with a 'line' in between. +(<$>) :: Doc -> Doc -> Doc +dl <$> dr = dl <> line <> dr + +-- | Combine with a 'linebreak' in between. +(<$$>) :: Doc -> Doc -> Doc +dl <$$> dr = dl <> linebreak <> dr + +-- | Combine with a 'softline' in between. +() :: Doc -> Doc -> Doc +dl dr = dl <> softline <> dr + +-- | Combine with a 'softbreak' in between. +() :: Doc -> Doc -> Doc +dl dr = dl <> softbreak <> dr + +-- ** Combining lists of documents +-- These combinators all assume a non-empty list of documents +-- and they do not start a new line at the end (unlike PPrint). + +-- | Combine non-empty list of documents with '<+>', i.e., a space separator. +hsep :: [Doc] -> Doc +hsep = foldr1 (<+>) -- differs from PPrint + +-- | Combine non-empty list of documents with '<$>', i.e., a 'line' separator. +vsep :: [Doc] -> Doc +vsep = foldr1 (<$>) -- differs from PPrint + +-- | Combine non-empty list of documents with '', i.e., a 'softline' separator. +fillSep :: [Doc] -> Doc +fillSep = foldr1 () -- differs from PPrint + +-- | Combine non-empty list of documents vertically as a group. +-- Seperated by space instead if all fit on one line. +sep :: [Doc] -> Doc +sep xs = group (vsep xs) -- differs from PPrint + +-- | Combine non-empty list of documents with '<>'. +hcat :: [Doc] -> Doc +hcat = foldr1 (<>) -- differs from PPrint + +-- | Combine non-empty list of documents with '<$$>', i.e., a 'linebreak' separator. +vcat :: [Doc] -> Doc +vcat = foldr1 (<$$>) -- differs from PPrint + +-- | Combine non-empty list of documents with '', i.e., a 'softbreak' separator. +fillCat :: [Doc] -> Doc +fillCat = foldr1 () -- differs from PPrint + +-- | Combine non-empty list of documents, filling lines as far as possible. +cat :: [Doc] -> Doc +cat xs = group (vcat xs) -- differs from PPrint + +------------------- +-- basic combinators + +-- | The empty document; equal to text \"\". +empty :: Doc + +-- | Atomic document consisting of just the given text. +-- There should be no newline \\n in the string. +text :: String -> Doc + +-- | Either a space or a new line. +line :: Doc + +-- | Either nothing ('empty') or a new line. +linebreak :: Doc + +-- | Horizontal composition of two documents. +-- Is associative with identity 'empty'. +(<>) :: Doc -> Doc -> Doc + +-- | Mark document as group, that is, layout as a single line if possible. +-- Within a group for all basic documents with several layouts the same layout +-- is chosen, that is, they are all horizontal or all new lines. +-- Within a vertical group there can be a horizontal group, but within a +-- horizontal group all groups are also layouted horizontally. +group :: Doc -> Doc + +-- | Increases current indentation level (absolute). Assumes argument >= 0. +nest :: Int -> Doc -> Doc + +-- | Set indentation to current column. +align :: Doc -> Doc + +-- | Pretty print within given width. +-- Selects from the *set* of layouts that the document represents the widest +-- that fits within the given width. +-- If no such layout exists, then it will choose the narrowest that exceeds the given +-- width. +pretty :: Int -> Doc -> String + +-- | A Document represents a *set* of layouts. +data Doc = Text Int String -- includes length of text string + | Nil + | Line Int String -- includes length of optional text + | Doc :<> Doc + | Group Doc + | Nest Int Doc -- increase current indentation + | Align Int Doc -- set indentation to current column plus increment + deriving Show + +empty = Nil +text t = Text (length t) t +line = Line 1 " " +linebreak = Line 0 "" +(<>) = (:<>) +group = Group +nest = Nest +align = Align 0 +pretty w d = interpret (normalise d) w (\p dq r i -> "") 0 Dequeue.empty w [0] + + +-- semantic-preserving transformation that ensures that between every end +-- of group and a subsequent line there is no text +-- It introduces many superfluous Nils, but it avoids being too strict. +-- Thus e.g. prop3 succeeds. +normalise :: Doc -> Doc +normalise d = td :<> sd + where + (td,sd) = go d Nil + -- Assume second argument only built from text,nil and <>. + -- Ensures first component of result built only from text,nil and <>. + -- go d tt = (td,sd) implies d <> tt and td <> sd denote the same set of + -- layouts. + go :: Doc -> Doc -> (Doc,Doc) + go Nil tt = (tt,Nil) + go (Text l t) tt = (Text l t :<> tt,Nil) + go (Line l t) tt = (Nil,Line l t :<> tt) + go (dl :<> dr) tt = let (tdl,sdl) = go dl tdr + (tdr,sdr) = go dr tt + in (tdl,sdl :<> sdr) + go (Group d) tt = let (td,sd) = go d tt in (td,Group sd) + go (Nest i d) tt = let (td,sd) = go d tt in (td,Nest i sd) + go (Align i d) tt = let (td,sd) = go d tt in (td,Align (i - docLength td) sd) + + +-- Determine length of a document consisting only of text,nil and <>. +-- To ensure linear complexity for align should actually keep track +-- of document length within go function itself. +docLength :: Doc -> Int +docLength Nil = 0 +docLength (Text l _) = l +docLength (dl :<> dr) = docLength dl + docLength dr + +type Width = Int +type Position = Int +type Indentation = Int +type Horizontal = Bool +type Remaining = Int +type Out = Remaining -> [Indentation] -> String + -- indentation needed here because of align combinator + -- need list to reset indentation to old value at end of a Nest or Align +type OutGroup = Horizontal -> Out -> Out +type TreeCont = Position -> Dequeue.Seq (Position,OutGroup) -> Out + + +interpret :: Doc -> Width -> TreeCont -> TreeCont +interpret Nil w tc p ds = tc p ds +interpret (Text l t) w tc p ds = + extendFrontGroup id prune outText tc (p+l) ds + where + outText :: OutGroup + outText h c r is = t ++ c (r-l) is +interpret (Line l t) w tc p ds = + extendFrontGroup id prune outLine tc (p+l) ds + where + outLine :: OutGroup + outLine h c r is = if h then t ++ c (r-l) is + else '\n' : replicate i ' ' ++ c (w-i) is + where + i = head is +interpret (dl :<> dr) w tc p ds = + interpret dl w (interpret dr w tc) p ds +interpret (Group d) w tc p ds = + interpret d w (leaveGroup tc) p ((p,\h c -> c) <| ds) +interpret (Nest j d) w tc p ds = + extendFrontGroup (interpret d w) (interpret d w) outNest (extendFrontGroup id id outResetIndent tc) p ds + where + outNest :: OutGroup + outNest h c r is = let i = head is in c r (max 0 (i+j) : is) -- max ensures reasonable behaviour if increment is negative +interpret (Align j d) w tc p ds = + extendFrontGroup (interpret d w) (interpret d w) outAlign (extendFrontGroup id id outResetIndent tc) p ds + where + outAlign :: OutGroup + outAlign h c r is = c r (max 0 (w-r+j) : is) -- max ensures reasonable behaviour if increment is negative + +outResetIndent :: OutGroup +outResetIndent h c r (i:is) = c r is + +-- If no pending groups, then do out directly, +-- otherwise add out to pending group, applying given prune function. +-- This extracts an otherwise repeated pattern of the interpret function. +extendFrontGroup :: (TreeCont -> TreeCont) -> (TreeCont -> TreeCont) -> + OutGroup -> TreeCont -> TreeCont +extendFrontGroup cont1 cont2 out tc p ds = + case viewl ds of + EmptyL -> out False (cont1 tc p ds) + (s,outGrp) :< ds' -> + cont2 tc p ((s,\h c -> outGrp h (out h c)) <| ds') + + +leaveGroup :: TreeCont -> TreeCont +leaveGroup tc p ds = + case viewl ds of + EmptyL -> tc p ds + (s1,outGrp1) :< ds1 -> + case viewl ds1 of + EmptyL -> outGrp1 True (tc p Dequeue.empty) + (s2,outGrp2) :< ds2 -> + tc p ((s2, \f c -> outGrp2 f (\r1 -> outGrp1 (p <= s2+r1) c r1)) <| ds2) + + +prune :: TreeCont -> TreeCont +prune tc p ds = + case viewr ds of + EmptyR -> tc p ds + ds' :> (s,outGrp) -> \r -> if p > s+r + then outGrp False (prune tc p ds') r + else tc p ds r + + +-- ------------------------------------------- +-- Properties for testing. All should be True. + +prop = prop0 && prop1 && prop2 && prop3 && prop4 && prop5 && prop6 && + prop7 && prop8 && prop9 && prop10 && prop11 && prop12 + +prop0 = pretty 6 (group (text "Hi" <> line <> text "you") <> text "!") == + "Hi\nyou!" +prop1 = pretty 4 (group (text "hi" <> line <> text "world")) == + "hi\nworld" +prop2 = + pretty 8 (group (text "hi" <> line <> text "world") <> text "liness") == + "hi\nworldliness" +prop3 = + take 6 (pretty 4 (group (text "hi" <> line <> text "you" <> undefined))) == + "hi\nyou" +prop4 = + take 6 (pretty 4 (group (text "hi" <> line) <> + group (text "you" <> line) <> undefined)) == + "hi\nyou" +prop5 = + take 6 (pretty 4 (group (text "hi" <> + group (line <> text "you" <> undefined)))) == + "hi\nyou" +prop6 = + take 7 (pretty 3 (group (text "hi" <> line <> + group (line <> text "you" <> undefined)))) == + "hi\n\nyou" +prop7 = + pretty 10 (group (text "what" <> + align (group (text "do" <> line <> text "you" <> line <> + text "do" <> align (line <> text "now?"))))) == + "whatdo\n you\n do\n now?" + +prop8 = + pretty 10 (group (text "one " <> (align (line <> text "two" <> + align (line <> text "three"))))) == + "one \n two\n three" + +prop9 = + pretty 10 (group (text "one " <> (nest 2 (line <> text "two" <> + nest 3 (line <> text "three"))))) == + "one \n two\n three" + +prop10 = + pretty 5 (group (nest 2 (text "one" <> line <> text "two")) <> + group (line <> text "three")) == + "one\n two\nthree" + +prop11 = + pretty 10 (text "one" <> softline <> (align (group (text "two" <> line <> text "three"))) <> + softline <> text "four") == + "one two\n three\nfour" + +prop12 = + pretty 15 (group ( text "this" + <> nest 9 (line <> group (text "takes" <> line <> text "four")) + <> line <> text "lines")) == + "this\n takes\n four\nlines" diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,13 @@ +0.4.0 Maarten Faddegon 9 Sep 2017 + + * Text based interface to the debugger for closer integration with an interpreter (e.g. ghci) + * Remove many dependencies + * Small tweaks to make Hoed work with a broader range of GHC versions + +0.3.6 Maarten Faddegon 22 May 2016 + + * Some minor fixes + 0.3.5 Maarten Faddegon 9 Feb 2016 * Give more control to restrict properties when used for judging to make approach sound. diff --git a/configure.Stk b/configure.Stk deleted file mode 100644 --- a/configure.Stk +++ /dev/null @@ -1,9 +0,0 @@ -CABAL_VER=`cabal --numeric-version | sed 's/\./ /g'` -MAJOR=`echo $CABAL_VER | awk '{print $1}'` -MINOR=`echo $CABAL_VER | awk '{print $2}'` - -if [ "$MAJOR" -le "1" -a "$MINOR" -le "18" ]; then - cabal configure --enable-executable-profiling --enable-library-profiling --disable-optimization --flags="validateStk" -else - cabal configure --enable-profiling --disable-optimization --flags="validateStk" -fi diff --git a/examples/CNF_unsound_demorgan__with_properties/Main.hs b/examples/CNF_unsound_demorgan__with_properties/Main.hs deleted file mode 100644 --- a/examples/CNF_unsound_demorgan__with_properties/Main.hs +++ /dev/null @@ -1,16 +0,0 @@ --- A program with unexpected output. -import CNF -import Debug.Hoed.Pure - -main = runOwp properties $ print (prop_negin_correct negin eg) - where - properties = [Propositions - [ mkProposition cnfModule "prop_negin_complete" - `ofType` BoolProposition - `withSignature` [SubjectFunction,Argument 0] - , mkProposition cnfModule "prop_negin_sound" - `ofType` BoolProposition - `withSignature` [SubjectFunction,Argument 0] - ] Specify "negin" [] - ] - cnfModule = Module "CNF" "../examples/CNF_unsound_demorgan__with_properties/" diff --git a/examples/Digraph_not_data_invariant__with_properties/Main.hs b/examples/Digraph_not_data_invariant__with_properties/Main.hs deleted file mode 100644 --- a/examples/Digraph_not_data_invariant__with_properties/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ --- A program with unexpected output. -import Digraph -import Debug.Hoed.Pure - -main = runOwp properties $ print (prop_assoc1toNdigraph eg) - where - properties = [ Propositions [mkProposition digraphModule "prop_assoc1toNdigraph" `ofType` BoolProposition `withSignature` [Argument 0]] - Specify "assoc1toNdigraph" [] - , Propositions [mkProposition digraphModule "prop_mergeAndSortTargets" `ofType` BoolProposition `withSignature` [Argument 0]] - Specify "mergeAndSortTargets" [] - , Propositions [mkProposition digraphModule "prop_addMissingSources" `ofType` BoolProposition `withSignature` [Argument 0]] - Specify "addMissingSources" [] - ] - digraphModule = Module "Digraph" "../examples/Digraph_not_data_invariant__with_properties/" diff --git a/examples/ExpressionSimplifier/Main1.hs b/examples/ExpressionSimplifier/Main1.hs deleted file mode 100644 --- a/examples/ExpressionSimplifier/Main1.hs +++ /dev/null @@ -1,6 +0,0 @@ --- A program with unexpected output. - -import MyModule -import Debug.Hoed.Pure - -main = testO prop_idemSimplify (Mul (Const 1) (Const 2)) diff --git a/examples/ExpressionSimplifier/Main2.hs b/examples/ExpressionSimplifier/Main2.hs deleted file mode 100644 --- a/examples/ExpressionSimplifier/Main2.hs +++ /dev/null @@ -1,16 +0,0 @@ --- A program with unexpected output. - -import MyModule -import Debug.Hoed.Pure - --- main = quickcheck prop_idemSimplify -main = testOwp properties prop_idemSimplify (Mul (Const 1) (Const 2)) - where - properties = [ Propositions [mkProposition myModule "prop_idemOne" `ofType` BoolProposition `withSignature` [Argument 0] - ] PropertiesOf "one" [] - , Propositions [ mkProposition myModule "prop_idemZero" `ofType` BoolProposition `withSignature` [Argument 0] - ] PropertiesOf "zero" [] - , Propositions [ mkProposition myModule "prop_idemSimplify" `ofType` BoolProposition `withSignature` [Argument 0] - ] PropertiesOf "simplify" [] - ] - myModule = Module "MyModule" "../examples/ExpressionSimplifier" diff --git a/examples/FPretty/Main.hs b/examples/FPretty/Main.hs deleted file mode 100644 --- a/examples/FPretty/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ -import FPretty -import Debug.Hoed.Pure - -main = runO $ case pretty 5 d of - "one\n two\nthree" -> putStrLn "Success!" - res -> putStrLn $ "Unexpected result:\n" ++ res - - where - d = group (nest 2 (text "one" <> softline <> text "two")) - <> group (softline <> text "three") diff --git a/examples/FPretty__CC/Main.hs b/examples/FPretty__CC/Main.hs deleted file mode 100644 --- a/examples/FPretty__CC/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ -import FPretty -import Debug.Hoed.Stk - -main = runO $ case pretty 5 d of - "one\n two\nthree" -> putStrLn "Success!" - res -> putStrLn $ "Unexpected result:\n" ++ res - - where - d = group (nest 2 (text "one" <> softline <> text "two")) - <> group (softline <> text "three") diff --git a/examples/Insertion_Sort_elements_disappear.hs b/examples/Insertion_Sort_elements_disappear.hs deleted file mode 100644 --- a/examples/Insertion_Sort_elements_disappear.hs +++ /dev/null @@ -1,23 +0,0 @@ --- Haskell version of the buggy insertion sort as shown in Lee Naish --- A Declarative Debugging Scheme. --- --- As Insort1, but with observe rather than templated observers. - -import Debug.Hoed.Pure - --- Insertion sort. -isort :: [Char] -> [Char] -isort = observe "isort" isort' -isort' [] = [] -isort' (n:ns) = insert n (isort ns) - --- Insert number into sorted list. -insert :: Char -> [Char] -> [Char] -insert = observe "insert" insert' -insert' :: Char -> [Char] -> [Char] -insert' n [] = [n] -insert' n (m:ms) - | n <= m = n : ms -- bug: `m' is missing in this case - | otherwise = m : (insert n ms) - -main = printO $ isort "bug" diff --git a/examples/Nubsort/Main.hs b/examples/Nubsort/Main.hs deleted file mode 100644 --- a/examples/Nubsort/Main.hs +++ /dev/null @@ -1,35 +0,0 @@ -import Debug.Hoed.Pure -import Nubsort - -main = testOwp ps prop_nub_idempotent [2,1,1] - where - ps = [ Propositions [ mkProposition nubsortModule "prop_nub_idempotent" - `ofType` BoolProposition - `withSignature`[Argument 0] - , mkProposition nubsortModule "prop_nub_unique" - `ofType` BoolProposition - `withSignature`[Argument 0] - , mkProposition nubsortModule "prop_nub_complete" - `ofType` BoolProposition - `withSignature`[Argument 0] - ] PropertiesOf "nub" [] - , Propositions [ mkProposition nubsortModule "prop_nubord'_idempotent" - `ofType` QuickCheckProposition - `withSignature`[Argument 1, Argument 0] - , mkProposition nubsortModule "prop_nubord'_unique" - `ofType` QuickCheckProposition - `withSignature`[Argument 1, Argument 0] - , mkProposition nubsortModule "prop_nubord'_complete" - `ofType` QuickCheckProposition - `withSignature`[Argument 1, Argument 0] - ] PropertiesOf "nubord'" [modQuickCheck] - , Propositions [ mkProposition nubsortModule "prop_insert_ordered" - `ofType` QuickCheckProposition - `withSignature`[Argument 1, Argument 0] - , mkProposition nubsortModule "prop_insert_complete" - `ofType` QuickCheckProposition - `withSignature`[Argument 1, Argument 0] - ] PropertiesOf "insert" [modQuickCheck] - ] - nubsortModule = Module "Nubsort" "../examples/Nubsort/" - modQuickCheck = Module "Test.QuickCheck" "" diff --git a/examples/Parity.hs b/examples/Parity.hs deleted file mode 100644 --- a/examples/Parity.hs +++ /dev/null @@ -1,19 +0,0 @@ --- A defective parity check. -import Debug.Hoed.Pure - -isOdd n = isEven (plusOne n) - -isEven = observe "isEven" isEven' -isEven' n = mod2 n == 0 - -plusOne = observe "plusOne" plusOne' -plusOne' n = n + 1 - -mod2 = observe "mod2" mod2' -mod2' n = div n 2 - -prop_isOdd :: Int -> Bool -prop_isOdd x = isOdd (2*x+1) - -main :: IO () -main = testO prop_isOdd 1 diff --git a/examples/Queens__with_properties/Main.hs b/examples/Queens__with_properties/Main.hs deleted file mode 100644 --- a/examples/Queens__with_properties/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Queens - -main = doit diff --git a/examples/Queens__with_properties/Main2.hs b/examples/Queens__with_properties/Main2.hs deleted file mode 100644 --- a/examples/Queens__with_properties/Main2.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Queens - -main = doit2 diff --git a/examples/Queens__with_properties/Main3.hs b/examples/Queens__with_properties/Main3.hs deleted file mode 100644 --- a/examples/Queens__with_properties/Main3.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Queens3 - -main = doit diff --git a/examples/Queens_defective_filter__with_properties/Main.hs b/examples/Queens_defective_filter__with_properties/Main.hs deleted file mode 100644 --- a/examples/Queens_defective_filter__with_properties/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Queens - -main = doit diff --git a/examples/Raincat/src/Main.hs b/examples/Raincat/src/Main.hs deleted file mode 100644 --- a/examples/Raincat/src/Main.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Main (main) where - -import Graphics.UI.GLUT -import System.Exit -import Game.GameInput -import Game.GameInit -import World.World -import Settings.DisplaySettings as DisplaySettings -import qualified Nxt.Graphics as NG -import Data.IORef -import Program.Program -import Debug.Hoed.Pure - -main :: IO () -main = runO $ do - NG.initWindow screenRes "Raincat" - NG.initGraphics screenResWidth screenResHeight - - worldState <- gameInit - worldStateRef <- newIORef worldState - - displayCallback $= programDraw worldStateRef - - keyboardMouseCallback $= Just (gameInput (keysStateRef worldState)) - motionCallback $= Just (gameMotion (mousePosRef worldState)) - passiveMotionCallback $= Just (gameMotion (mousePosRef worldState)) - - addTimerCallback 1 (programMain worldStateRef) - - mainLoop diff --git a/examples/Rot13.hs b/examples/Rot13.hs deleted file mode 100644 --- a/examples/Rot13.hs +++ /dev/null @@ -1,21 +0,0 @@ --- A defective ROT13 implemenation. -import Data.Maybe -import Data.Char -import Debug.Hoed.Pure - -main = printO (prop_rot13length "Abc") - ------------------------------------------------------------------------------ - -rot13 = observe "rot13" rot13' -normalize = observe "normalize" normalize' -rot13char = observe "rot13char" rot13char' - -rot13' = mapMaybe (\c -> rot13char (normalize c)) -normalize' c = lookup c (zip ['a'..'z'] ['A' .. 'Z']) -rot13char' Nothing = Nothing -rot13char' (Just c) = lookup c table - where table = zip ['A'..'Z'] (['N'..'Z'] ++ ['A'..'M']) - -prop_rot13length s = length t == length (rot13 t) - where t = filter isAlpha s diff --git a/examples/Salary.hs b/examples/Salary.hs deleted file mode 100644 --- a/examples/Salary.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -import Debug.Hoed.Pure - -avgSalary :: [Employee] -> Float -f :: [Employee] -> Float -avg :: Float -> Float -> Employee -> Float - ------------------------------------------------------------- --- defective computation of avarage salary (always 0.0) - -data Employee = Employee {getName :: String, getSalary :: Float} deriving Generic - -avgSalary es = foldl (avg 1.0) 0.0 es --- avgSalary es = foldl (avg (f es)) 0.0 es -f es = toFloat (1 `div` (length es)) -avg' x acc (Employee _ s) = acc + (x * s) - -instance Observable Employee --- avgSalary = observe "avgSalary" avgSalary' --- f = observe "f" f' -avg = observe "avg" avg' - ------------------------------------------------------------- --- properties - -newtype Positive a = Positive {getPositive :: a} deriving Show - -prop_avgSalaryPositive :: [Positive Float] -> Bool -prop_avgSalaryPositive ss = avgSalary (map mkEmployee ss) > 0.0 - where mkEmployee (Positive s) = Employee "X" s - ------------------------------------------------------------- - -main = testO prop_avgSalaryPositive ss - where ss = [Positive 3000.0, Positive 1800.0] - employees = [Employee "Aafje" 3000, Employee "Ben" 2000] - -toFloat :: Int -> Float -toFloat = fromInteger . toInteger diff --git a/examples/SimpleHO.hs b/examples/SimpleHO.hs deleted file mode 100644 --- a/examples/SimpleHO.hs +++ /dev/null @@ -1,9 +0,0 @@ -import Debug.Hoed.Pure - -ap4 :: (Int -> Int) -> Int -ap4 = observe "ap4" (\f -> f 4) - -mod2 :: Int -> Int -mod2 = observe "mod2" (\n -> div n 2) - -main = printO (ap4 mod2) diff --git a/examples/SternBrocot.lhs b/examples/SternBrocot.lhs deleted file mode 100644 --- a/examples/SternBrocot.lhs +++ /dev/null @@ -1,97 +0,0 @@ -We need the Template Haskell extension to splice in the generated -Observable instances. We need the Rank2Types extionsion to be able -to specify parametrized types such as 'Tree a' with forall a. - -> {-# LANGUAGE TemplateHaskell, Rank2Types #-} - -We need the Derive Generic extention to derive the Generic representation -used for the non spliced in observe (see the Cache data type). - -> {-# LANGUAGE DeriveGeneric #-} - -> import Debug.Hoed.Pure - -We use the Stern–Brocot tree as example. The Stern-Brocot tree is a -binary tree containing all rational numbers. The tree is infinit and -is therefore a nice example to demonstrate how laziness is handled. - -To store the tree we use the following datatype, note that because -our definition is endless we do not actually use Leaf. - -> data Tree a = Node a (Tree a) (Tree a) deriving Generic - -The values in the tree will be fractional numbers: - -> data Frac = Frac Int Int deriving (Show,Generic) - -We use cache to store what the last seen up and to the left, and up and -to the right values are. - -> data Cache = Cache { v :: Frac -> , l :: Frac -> , r :: Frac -> } deriving Generic - -Make Cache and Frac Observable for gdmobserve. - -> instance Observable Cache -> instance Observable Frac - -The mediant is used to find which new number to insert between 2 exisiting -numbers. - -> mediant :: Frac -> Frac -> Frac -> mediant (Frac p1 q1) (Frac p2 q2) = Frac (p1+p2) (q1+q2) - -Definition of the sternbrocot tree: - -> sternbrocot :: Tree Frac -> sternbrocot = sternbrocot' mediant -> -> sternbrocot' :: (Frac -> Frac -> Frac) -> Tree Frac -> sternbrocot' m = w_sternbrocot m Cache{v=(Frac 1 1), l=(Frac 0 1), r=(Frac 1 0)} -> -> w_sternbrocot :: (Frac -> Frac -> Frac) -> Cache -> Tree Frac -> w_sternbrocot m cache -> = let Cache{v=v, l=l, r=r} = cache -- observe "cache" cache -> in Node v (w_sternbrocot m Cache{v=m v l, l=l, r=v}) -> (w_sternbrocot m Cache{v=m v r, l=v, r=r}) - -The Stern-Brocot tree is sorted: all values in the left subtree are -smaller than the value of the current node and all values in the right subtree -are greater than the value in the current node. -This can be used to approximate a Float value by doing a binary search where -each next rational number is a better aproximation of the Float. - -> toFrac :: Float -> Tree Frac -> Frac -> toFrac val (Node frac@(Frac p q) left right) -> = case compare ((fromIntegral p) / (fromIntegral q)) val of -> LT -> toFrac val right -> GT -> toFrac val left -> EQ -> frac - -We use template-haskell to observe Tree and the values stored in Tree. - -> $(observedTypes "sternbrocot1" [ [t| forall a . Observable a => Tree a |] -> , [t| Frac |] -> ] -> ) -> -> frac1 = toFrac 0.6 ($(observeTempl "sternbrocot1") sternbrocot) - -Or to only observe which part of the tree is walked while ignoring -the values stored in the tree. - -> $(observedTypes "sternbrocot2" [ [t| forall a . Tree a |]]) -> -> frac2 = toFrac 0.6 ($(observeTempl "sternbrocot2") sternbrocot) - -> instance (Observable a) => Observable (Tree a) -> -> frac3 = toFrac 0.6 (observe "sternbrocot3" sternbrocot) - -Example main function: - -> main = runO $ do -- print frac1 -> -- print frac2 -> print frac3 diff --git a/examples/XMonad_changing_focus_duplicates_windows/Main.hs b/examples/XMonad_changing_focus_duplicates_windows/Main.hs deleted file mode 100644 --- a/examples/XMonad_changing_focus_duplicates_windows/Main.hs +++ /dev/null @@ -1,43 +0,0 @@ -import Properties -import Debug.Hoed.Pure -import System.Environment -import Text.Printf -import Control.Monad -import System.Random -import Test.QuickCheck -import Data.Maybe -import XMonad.StackSet -import qualified Data.Map as M - -myStackSet :: T -myStackSet = StackSet {current = Screen {workspace = Workspace {tag = NonNegative 2, layout = -2, stack = Just (Stack {focus = 'c', up = "", down = "z"})}, screen = 2, screenDetail = 1}, visible = [Screen {workspace = Workspace {tag = NonNegative 0, layout = -2, stack = Just (Stack {focus = 'd', up = "", down = ""})}, screen = 1, screenDetail = -2},Screen {workspace = Workspace {tag = NonNegative 3, layout = -2, stack = Just (Stack {focus = 'v', up = "", down = ""})}, screen = 3, screenDetail = -1},Screen {workspace = Workspace {tag = NonNegative 4, layout = -2, stack = Just (Stack {focus = 'w', up = "", down = "i"})}, screen = 0, screenDetail = -2}], hidden = [Workspace {tag = NonNegative 1, layout = -2, stack = Just (Stack {focus = 'n', up = "", down = ""})},Workspace {tag = NonNegative 0, layout = -2, stack = Nothing},Workspace {tag = NonNegative 4, layout = -2, stack = Nothing}], floating = M.fromList []} - - - -{- Running all tests -main = do - args <- fmap (drop 1) getArgs - let n = if null args then 100 else read (head args) - (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests - printf "Passed %d tests!\n" (sum passed) - when (not . and $ results) $ fail "Not all tests passed!" --} - -main :: IO () -main = runO $ do - g <- newStdGen - print . fromJust . ok . (generate 1 g) . evaluate $ prop_shift_win_I 1 'd' myStackSet - where - module_Properties = Module "Properties" "../examples/XMonad_changing_focus_duplicates_windows/" - module_StackSet = Module "XMonad.StackSet" "../examples/XMonad_changing_focus_duplicates_windows/" - module_QuickCheck = Module "Test.QuickCheck" "../examples/XMonad_changing_focus_duplicates_windows/" - module_Map = Module "qualified Data.Map as M" "" - module_Random = Module "System.Random" "" - module_Maybe = Module "Data.Maybe" "" - - tests = - [("shiftMaster id on focus", mytest prop_shift_master_focus) - ,("shiftWin: invariant" , mytest prop_shift_win_I) - ,("shiftWin is shift on focus" , mytest prop_shift_win_focus) - ,("shiftWin fix current" , mytest prop_shift_win_fix_current) - ] diff --git a/examples/XMonad_changing_focus_duplicates_windows__CC/Main.hs b/examples/XMonad_changing_focus_duplicates_windows__CC/Main.hs deleted file mode 100644 --- a/examples/XMonad_changing_focus_duplicates_windows__CC/Main.hs +++ /dev/null @@ -1,43 +0,0 @@ -import Properties -import Debug.Hoed.Stk -import System.Environment -import Text.Printf -import Control.Monad -import System.Random -import Test.QuickCheck -import Data.Maybe -import XMonad.StackSet -import qualified Data.Map as M - -myStackSet :: T -myStackSet = StackSet {current = Screen {workspace = Workspace {tag = NonNegative 2, layout = -2, stack = Just (Stack {focus = 'c', up = "", down = "z"})}, screen = 2, screenDetail = 1}, visible = [Screen {workspace = Workspace {tag = NonNegative 0, layout = -2, stack = Just (Stack {focus = 'd', up = "", down = ""})}, screen = 1, screenDetail = -2},Screen {workspace = Workspace {tag = NonNegative 3, layout = -2, stack = Just (Stack {focus = 'v', up = "", down = ""})}, screen = 3, screenDetail = -1},Screen {workspace = Workspace {tag = NonNegative 4, layout = -2, stack = Just (Stack {focus = 'w', up = "", down = "i"})}, screen = 0, screenDetail = -2}], hidden = [Workspace {tag = NonNegative 1, layout = -2, stack = Just (Stack {focus = 'n', up = "", down = ""})},Workspace {tag = NonNegative 0, layout = -2, stack = Nothing},Workspace {tag = NonNegative 4, layout = -2, stack = Nothing}], floating = M.fromList []} - - - -{- Running all tests -main = do - args <- fmap (drop 1) getArgs - let n = if null args then 100 else read (head args) - (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests - printf "Passed %d tests!\n" (sum passed) - when (not . and $ results) $ fail "Not all tests passed!" --} - -main :: IO () -main = runO $ do - g <- newStdGen - print . fromJust . ok . (generate 1 g) . evaluate $ prop_shift_win_I 1 'd' myStackSet - -- where - -- module_Properties = Module "Properties" "../examples/XMonad_changing_focus_duplicates_windows/" - -- module_StackSet = Module "XMonad.StackSet" "../examples/XMonad_changing_focus_duplicates_windows/" - -- module_QuickCheck = Module "Test.QuickCheck" "../examples/XMonad_changing_focus_duplicates_windows/" - -- module_Map = Module "qualified Data.Map as M" "" - -- module_Random = Module "System.Random" "" - -- module_Maybe = Module "Data.Maybe" "" - - -- tests = - -- [("shiftMaster id on focus", mytest prop_shift_master_focus) - -- ,("shiftWin: invariant" , mytest prop_shift_win_I) - -- ,("shiftWin is shift on focus" , mytest prop_shift_win_focus) - -- ,("shiftWin fix current" , mytest prop_shift_win_fix_current) - -- ] diff --git a/examples/XMonad_changing_focus_duplicates_windows__test_only/Main.hs b/examples/XMonad_changing_focus_duplicates_windows__test_only/Main.hs deleted file mode 100644 --- a/examples/XMonad_changing_focus_duplicates_windows__test_only/Main.hs +++ /dev/null @@ -1,171 +0,0 @@ -import Properties -import Debug.Hoed.NoTrace -import System.Environment -import Text.Printf -import Control.Monad -import System.Random -import Test.QuickCheck -import Data.Maybe -import XMonad.StackSet -import qualified Data.Map as M - -myStackSet :: T -myStackSet = StackSet {current = Screen {workspace = Workspace {tag = NonNegative 2, layout = -2, stack = Just (Stack {focus = 'c', up = "", down = "z"})}, screen = 2, screenDetail = 1}, visible = [Screen {workspace = Workspace {tag = NonNegative 0, layout = -2, stack = Just (Stack {focus = 'd', up = "", down = ""})}, screen = 1, screenDetail = -2},Screen {workspace = Workspace {tag = NonNegative 3, layout = -2, stack = Just (Stack {focus = 'v', up = "", down = ""})}, screen = 3, screenDetail = -1},Screen {workspace = Workspace {tag = NonNegative 4, layout = -2, stack = Just (Stack {focus = 'w', up = "", down = "i"})}, screen = 0, screenDetail = -2}], hidden = [Workspace {tag = NonNegative 1, layout = -2, stack = Just (Stack {focus = 'n', up = "", down = ""})},Workspace {tag = NonNegative 0, layout = -2, stack = Nothing},Workspace {tag = NonNegative 4, layout = -2, stack = Nothing}], floating = M.fromList []} - - - -main = do - args <- fmap (drop 1) getArgs - let n = if null args then 100 else read (head args) - (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests - printf "Passed %d tests!\n" (sum passed) - when (not . and $ results) $ fail "Not all tests passed!" - - where - - tests = zipWith (\(name,test) number -> (show number ++ ": " ++ name,test)) tests' [1..] - - tests' = - [("prop_invariant" , mytest prop_invariant) - - ,("prop_empty_I" , mytest prop_empty_I) - ,("prop_empty" , mytest prop_empty) - ,("prop_empty_current" , mytest prop_empty_current) - ,("prop_member_empty" , mytest prop_member_empty) - - ,("prop_view_I" , mytest prop_view_I) - ,("prop_view_current" , mytest prop_view_current) - ,("prop_view_idem" , mytest prop_view_idem) - ,("prop_view_reversible" , mytest prop_view_reversible) - ,("prop_view_local" , mytest prop_view_local) - - ,("prop_view_greedyView_I" , mytest prop_greedyView_I) - ,("prop_greedyView_current" , mytest prop_greedyView_current) - ,("prop_greedyView_current_id" , mytest prop_greedyView_current_id) - ,("prop_greedyView_idem" , mytest prop_greedyView_idem) - ,("prop_greedyView_reversible" , mytest prop_greedyView_reversible) - ,("prop_greedyView_local" , mytest prop_greedyView_local) - - ,("prop_member_peek" , mytest prop_member_peek) - - ,("prop_index_length" , mytest prop_index_length) - - ,("prop_focusUp_I", mytest prop_focusUp_I) - ,("prop_focusMaster_I", mytest prop_focusMaster_I) - ,("prop_focusDown_I", mytest prop_focusDown_I) - ,("prop_focus_I", mytest prop_focus_I) - ,("prop_focus_left_master" , mytest prop_focus_left_master) - ,("prop_focus_right_master" , mytest prop_focus_right_master) - ,("prop_focus_master_master" , mytest prop_focus_master_master) - ,("prop_focusWindow_master" , mytest prop_focusWindow_master) - ,("prop_focus_left" , mytest prop_focus_left) - ,("prop_focus_right" , mytest prop_focus_right) - ,("prop_focus_all_l" , mytest prop_focus_all_l) - ,("prop_focus_all_r" , mytest prop_focus_all_r) - ,("prop_focus_down_local" , mytest prop_focus_down_local) - ,("prop_focus_up_local" , mytest prop_focus_up_local) - ,("prop_focus_master_local" , mytest prop_focus_master_local) - ,("prop_focusMaster_idem" , mytest prop_focusMaster_idem) - - ,("prop_focusWindow_local", mytest prop_focusWindow_local) - ,("prop_focusWindow_works" , mytest prop_focusWindow_works) - ,("prop_focusWindow_identity", mytest prop_focusWindow_identity) - - ,("prop_findIndex" , mytest prop_findIndex) - ,("prop_allWindowsMember" , mytest prop_allWindowsMember) - ,("prop_currentTag" , mytest prop_currentTag) - - ,("prop_insertUp_I" , mytest prop_insertUp_I) - ,("prop_insert_empty/new" , mytest prop_insert_empty) - ,("prop_insert_idem", mytest prop_insert_idem) - ,("prop_insert_delete", mytest prop_insert_delete) - ,("prop_insert_local" , mytest prop_insert_local) - ,("prop_insert_duplicate" , mytest prop_insert_duplicate) - ,("prop_insert_peek" , mytest prop_insert_peek) - ,("prop_size_insert" , mytest prop_size_insert) - - ,("prop_delete_I" , mytest prop_delete_I) - ,("prop_empty" , mytest prop_empty) - ,("prop_delete" , mytest prop_delete) - ,("prop_delete_insert", mytest prop_delete_insert) - ,("prop_delete_local" , mytest prop_delete_local) - ,("prop_delete_focus" , mytest prop_delete_focus) - ,("prop_delete_focus_end", mytest prop_delete_focus_end) - ,("prop_delete_focus_not_end", mytest prop_delete_focus_not_end) - - ,("prop_filter_order", mytest prop_filter_order) - - ,("prop_swap_master_I", mytest prop_swap_master_I) - ,("prop_swap_left_I" , mytest prop_swap_left_I) - ,("prop_swap_right_I", mytest prop_swap_right_I) - ,("prop_swap_master_focus", mytest prop_swap_master_focus) - ,("prop_swap_left_focus", mytest prop_swap_left_focus) - ,("prop_swap_right_focus", mytest prop_swap_right_focus) - ,("prop_swap_master_idempotent", mytest prop_swap_master_idempotent) - ,("prop_swap_all_l" , mytest prop_swap_all_l) - ,("prop_swap_all_r" , mytest prop_swap_all_r) - ,("prop_swap_master_local" , mytest prop_swap_master_local) - ,("prop_swap_left_local" , mytest prop_swap_left_local) - ,("prop_swap_right_local" , mytest prop_swap_right_local) - - ,("prop_shift_master_focus", mytest prop_shift_master_focus) - ,("prop_shift_master_local", mytest prop_shift_master_local) - ,("prop_shift_master_idempotent", mytest prop_shift_master_idempotent) - ,("prop_shift_master_ordering", mytest prop_shift_master_ordering) - - ,("prop_shift_I" , mytest prop_shift_I) - ,("prop_shift_reversible" , mytest prop_shift_reversible) - ,("prop_shift_win_I" , mytest prop_shift_win_I) - ,("prop_shift_win_focus" , mytest prop_shift_win_focus) - ,("prop_shift_win_fix_current" , mytest prop_shift_win_fix_current) - - ,("prop_float_reversible" , mytest prop_float_reversible) - ,("prop_float_geometry" , mytest prop_float_geometry) - ,("prop_float_delete", mytest prop_float_delete) - ,("prop_screens", mytest prop_screens) - - ,("prop_differentiate", mytest prop_differentiate) - ,("prop_lookup_current", mytest prop_lookup_current) - ,("prop_lookup_visible", mytest prop_lookup_visible) - ,("prop_screens_works", mytest prop_screens_works) - ,("prop_rename1", mytest prop_rename1) - ,("prop_ensure", mytest prop_ensure) - ,("prop_ensure_append", mytest prop_ensure_append) - - ,("prop_mapWorkspaceId", mytest prop_mapWorkspaceId) - ,("prop_mapWorkspaceInverse", mytest prop_mapWorkspaceInverse) - ,("prop_mapLayoutId", mytest prop_mapLayoutId) - ,("prop_mapLayoutInverse", mytest prop_mapLayoutInverse) - - -- testing for failure: - ,("prop_abort", mytest prop_abort) - ,("prop_new_abort", mytest prop_new_abort) - ,("prop_shift_win_indentity", mytest prop_shift_win_indentity) - - -- tall layout - - ,("prop_tile_fullscreen", mytest prop_tile_fullscreen) - ,("prop_tile_non_overlap", mytest prop_tile_non_overlap) - ,("prop_split_hoziontal", mytest prop_split_hoziontal) - ,("prop_splitVertically", mytest prop_splitVertically) - - ,("prop_purelayout_tall", mytest prop_purelayout_tall) - ,("prop_shrink_tall", mytest prop_shrink_tall) - ,("prop_expand_tall", mytest prop_expand_tall) - ,("prop_incmaster_tall", mytest prop_incmaster_tall) - - -- full layout - - ,("prop_purelayout_full", mytest prop_purelayout_full) - ,("prop_sendmsg_full", mytest prop_sendmsg_full) - ,("prop_desc_full", mytest prop_desc_full) - - ,("prop_desc_mirror", mytest prop_desc_mirror) - - -- resize hints - ,("prop_resize_inc", mytest prop_resize_inc) - ,("prop_resize_inc_extra", mytest prop_resize_inc_extra) - ,("prop_resize_max", mytest prop_resize_max) - ,("prop_resize_max_extra", mytest prop_resize_max_extra) - - ] diff --git a/examples/XMonad_changing_focus_duplicates_windows__using_properties/Main.hs b/examples/XMonad_changing_focus_duplicates_windows__using_properties/Main.hs deleted file mode 100644 --- a/examples/XMonad_changing_focus_duplicates_windows__using_properties/Main.hs +++ /dev/null @@ -1,93 +0,0 @@ -import Properties -import Debug.Hoed.Pure -import System.Environment -import Text.Printf -import Control.Monad -import System.Random -import Test.QuickCheck -import Data.Maybe -import XMonad.StackSet -import qualified Data.Map as M - -myStackSet :: T -myStackSet = StackSet {current = Screen {workspace = Workspace {tag = NonNegative 2, layout = -2, stack = Just (Stack {focus = 'c', up = "", down = "z"})}, screen = 2, screenDetail = 1}, visible = [Screen {workspace = Workspace {tag = NonNegative 0, layout = -2, stack = Just (Stack {focus = 'd', up = "", down = ""})}, screen = 1, screenDetail = -2},Screen {workspace = Workspace {tag = NonNegative 3, layout = -2, stack = Just (Stack {focus = 'v', up = "", down = ""})}, screen = 3, screenDetail = -1},Screen {workspace = Workspace {tag = NonNegative 4, layout = -2, stack = Just (Stack {focus = 'w', up = "", down = "i"})}, screen = 0, screenDetail = -2}], hidden = [Workspace {tag = NonNegative 1, layout = -2, stack = Just (Stack {focus = 'n', up = "", down = ""})},Workspace {tag = NonNegative 0, layout = -2, stack = Nothing},Workspace {tag = NonNegative 4, layout = -2, stack = Nothing}], floating = M.fromList []} - - -main :: IO () -main = runOwp propositions $ do - g <- newStdGen - print . fromJust . ok . (generate 1 g) . evaluate $ prop_shift_win_I shiftWin 1 'd' myStackSet - where - propositions = - [ Propositions [mkProposition module_Properties "prop_shift_win_I" - `ofType` LegacyQuickCheckProposition - `withSignature` [SubjectFunction, Argument 0, Argument 1, Argument 2] - `withTestGen` TestGenLegacyQuickCheck - ] - PropertiesOf "shiftWin" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - , Propositions [mkProposition module_Properties "prop_focus_all_l" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0] - `withTestGen` TestGenLegacyQuickCheck - ,mkProposition module_Properties "prop_focus_all_l_weak" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0] - `withTestGen` TestGenLegacyQuickCheck - ] - PropertiesOf "focusUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - , Propositions [ mkProposition module_Properties "prop_insert_duplicate_weak" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0, Argument 1] - `withTestGen` TestGenLegacyQuickCheck - ] - PropertiesOf "insertUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - , Propositions [ mkProposition module_Properties "prop_view_reversible" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0, Argument 1] - `withTestGen` TestGenLegacyQuickCheck - , mkProposition module_Properties "prop_view_I" - `ofType` LegacyQuickCheckProposition - `withSignature` [SubjectFunction, Argument 0, Argument 1] - `withTestGen` TestGenLegacyQuickCheck - , mkProposition module_Properties "prop_view_current" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - `withTestGen` TestGenLegacyQuickCheck - , mkProposition module_Properties "prop_view_idem" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - `withTestGen` TestGenLegacyQuickCheck - , mkProposition module_Properties "prop_view_local" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - `withTestGen` TestGenLegacyQuickCheck - ] - PropertiesOf "view" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - , Propositions [ mkProposition module_Properties "prop_greedyView_reversible" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0, Argument 1] - `withTestGen` TestGenLegacyQuickCheck - , mkProposition module_Properties "prop_greedyView_idem" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - `withTestGen` TestGenLegacyQuickCheck - ] - PropertiesOf "greedyView" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - , Propositions [ mkProposition module_Properties "prop_findIndex" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1] - `withTestGen` TestGenLegacyQuickCheck - ] - PropertiesOf "findTag" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - ] - - module_Properties = Module "Properties" "../examples/XMonad_changing_focus_duplicates_windows__using_properties/" - module_StackSet = Module "XMonad.StackSet" "../examples/XMonad_changing_focus_duplicates_windows__using_properties/" - module_QuickCheck = Module "Test.QuickCheck" "../examples/XMonad_changing_focus_duplicates_windows__using_properties/" - module_Map = Module "qualified Data.Map as M" "" - module_Random = Module "System.Random" "" - module_Maybe = Module "Data.Maybe" "" diff --git a/examples/ZLang/1/Main.hs b/examples/ZLang/1/Main.hs deleted file mode 100644 --- a/examples/ZLang/1/Main.hs +++ /dev/null @@ -1,39 +0,0 @@ -import Parser as P -import TypeInfer as T -import MatchCheck as MC -import Control.Monad.Trans.Writer.Lazy -import qualified Data.List as List - --- TEST RELATED BEGIN -import Types -import TypedAst -import qualified Data.Map as Map -import Debug.Hoed.Pure - -failType = Record False [("a",IntType),("b",StringType)] - -m1 = (TRecordMatchExpr [("a",(TIntMatchExpr 42,IntType)),("b",(TStringMatchExpr "abc",StringType))],Record False [("a",IntType),("b",StringType)]) -m2 = (TRecordMatchExpr [("a",(TVarMatch "n",IntType)),("b",(TStringMatchExpr "def",StringType))],Record False [("a",IntType),("b",StringType)]) -m3 = (TRecordMatchExpr [("a",(TVarMatch "n",IntType)),("b",(TVarMatch "s",StringType))],Record False [("a",IntType),("b",StringType)]) - -testCovering ty matches = covering Map.empty (ideal Map.empty ty) matches == [Covered] --- TEST RELATED END - -concreteTest = testCovering failType [m1, m2, m3] - -main = printO $ concreteTest - -{- -main :: IO () -main = let path = "../test.z" - in do content <- readFile path - case P.parse content of - Left err -> print err - Right ast -> do - (typed, env, subst) <- T.infer ast - let (b, badMatches) = runWriter (MC.matchCheck env typed) - mapM putStrLn (List.map MC.formatMatchWarning badMatches) - case b of - True -> return () --Continue compilation - False -> return () --Abort compilation --} diff --git a/examples/ZLang/2/Main.hs b/examples/ZLang/2/Main.hs deleted file mode 100644 --- a/examples/ZLang/2/Main.hs +++ /dev/null @@ -1,39 +0,0 @@ -import Parser as P -import TypeInfer as T -import MatchCheck as MC -import Control.Monad.Trans.Writer.Lazy -import qualified Data.List as List - --- TEST RELATED BEGIN -import Types -import TypedAst -import qualified Data.Map as Map -import Debug.Hoed.Pure - -failType = Record False [("a",IntType),("b",StringType)] - -m1 = (TRecordMatchExpr [("a",(TIntMatchExpr 42,IntType)),("b",(TStringMatchExpr "abc",StringType))],Record False [("a",IntType),("b",StringType)]) -m2 = (TRecordMatchExpr [("a",(TVarMatch "n",IntType)),("b",(TStringMatchExpr "def",StringType))],Record False [("a",IntType),("b",StringType)]) -m3 = (TRecordMatchExpr [("a",(TVarMatch "n",IntType)),("b",(TVarMatch "s",StringType))],Record False [("a",IntType),("b",StringType)]) - -testCovering ty matches = covering Map.empty (ideal Map.empty ty) matches == [Covered] --- TEST RELATED END - -concreteTest = testCovering failType [m1, m2, m3] - -main = printO $ concreteTest - -{- -main :: IO () -main = let path = "../test.z" - in do content <- readFile path - case P.parse content of - Left err -> print err - Right ast -> do - (typed, env, subst) <- T.infer ast - let (b, badMatches) = runWriter (MC.matchCheck env typed) - mapM putStrLn (List.map MC.formatMatchWarning badMatches) - case b of - True -> return () --Continue compilation - False -> return () --Abort compilation --} diff --git a/examples/ZLang/3/Main.hs b/examples/ZLang/3/Main.hs deleted file mode 100644 --- a/examples/ZLang/3/Main.hs +++ /dev/null @@ -1,39 +0,0 @@ -import Parser as P -import TypeInfer as T -import MatchCheck as MC -import Control.Monad.Trans.Writer.Lazy -import qualified Data.List as List - --- TEST RELATED BEGIN -import Types -import TypedAst -import qualified Data.Map as Map -import Debug.Hoed.Pure - -failType = Record False [("a",IntType),("b",StringType)] - -m1 = (TRecordMatchExpr [("a",(TIntMatchExpr 42,IntType)),("b",(TStringMatchExpr "abc",StringType))],Record False [("a",IntType),("b",StringType)]) -m2 = (TRecordMatchExpr [("a",(TVarMatch "n",IntType)),("b",(TStringMatchExpr "def",StringType))],Record False [("a",IntType),("b",StringType)]) -m3 = (TRecordMatchExpr [("a",(TVarMatch "n",IntType)),("b",(TVarMatch "s",StringType))],Record False [("a",IntType),("b",StringType)]) - -testCovering ty matches = covering Map.empty (ideal Map.empty ty) matches == [Covered] --- TEST RELATED END - -concreteTest = testCovering failType [m1, m2, m3] - -main = printO $ concreteTest - -{- -main :: IO () -main = let path = "../test.z" - in do content <- readFile path - case P.parse content of - Left err -> print err - Right ast -> do - (typed, env, subst) <- T.infer ast - let (b, badMatches) = runWriter (MC.matchCheck env typed) - mapM putStrLn (List.map MC.formatMatchWarning badMatches) - case b of - True -> return () --Continue compilation - False -> return () --Abort compilation --} diff --git a/examples/afp02Exercises/Compiler/Main.hs b/examples/afp02Exercises/Compiler/Main.hs deleted file mode 100644 --- a/examples/afp02Exercises/Compiler/Main.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Main where - -import Debug.Hoed.Pure -import Syntax -import Parser -import Interpreter -import Machine -import Compiler - -main = runO $ do - let prog = parse gcdSource - putStrLn "interpreted:" - print (obey prog) - putStrLn "compiled:" - print (exec (compile prog)) - -gcdSource :: String -gcdSource = "x := 148; y := 58;\nwhile ~(x=y) do\n if x < y then y := y - x\n else x := x - y\n fi\nod;\nprint x\n" diff --git a/examples/afp02Exercises/Compiler__with_properties/Main.hs b/examples/afp02Exercises/Compiler__with_properties/Main.hs deleted file mode 100644 --- a/examples/afp02Exercises/Compiler__with_properties/Main.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Main where - -import Debug.Hoed.Pure -import Syntax -import Parser -import Interpreter -import Machine -import Compiler - -main = runOwp properties $ do - let prog = parse gcdSource - putStrLn "interpreted:" - print (obey prog) - putStrLn "compiled:" - print (exec (compile prog)) - where - properties = [Propositions [mkProposition modInterpreter "prop_ifT" - `ofType` BoolProposition - `withSignature`[Argument 1, Argument 0] - ]PropertiesOf "run" [modSyntax,modValue,modQuickCheck] - ] - modInterpreter = Module "Interpreter" "../examples/afp02Exercises/Compiler__with_properties/" - modValue = Module "Value" "../examples/afp02Exercises/Compiler__with_properties/" - modSyntax = Module "Syntax" "../examples/afp02Exercises/Compiler__with_properties/" - modQuickCheck = Module "Test.QuickCheck" "" - -gcdSource :: String -gcdSource = "x := 148; y := 58;\nwhile ~(x=y) do\n if x < y then y := y - x\n else x := x - y\n fi\nod;\nprint x\n" diff --git a/examples/filter__with_properties/Main.hs b/examples/filter__with_properties/Main.hs deleted file mode 100644 --- a/examples/filter__with_properties/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Even - -main = doit diff --git a/test.Stk b/test.Stk deleted file mode 100644 --- a/test.Stk +++ /dev/null @@ -1,31 +0,0 @@ -#!/bin/bash - -TESTS=`ls dist/build | grep hoed-tests-Stk` -FAIL=0 - -echo "Testing Hoed-stk" -echo - -# Ensure there is a directory to execute in. -if [ ! -d tests/exe ]; then - mkdir tests/exe -fi - -rm -f tests/exe/* -cd tests/exe -for t in $TESTS; do - eval ../../dist/build/$t/$t &> $t.out - diff $t.graph ../ref/$t.graph &> $t.diff - if [ $? -eq 0 ]; then - echo "[OK] $t" - else - FAIL=1 - echo -n "[" - echo -en '\E[37;31m'"\033[1m!!\033[0m" # red "!!" on white background - tput sgr0 # reset colour - echo "] $t" - diff -y $t.graph ../ref/$t.graph # a side-by-side comparison - fi -done - -exit $FAIL diff --git a/tests/Generic/r0.hs b/tests/Generic/r0.hs deleted file mode 100644 --- a/tests/Generic/r0.hs +++ /dev/null @@ -1,13 +0,0 @@ -import Debug.Hoed.Pure - -data D = D Int - deriving Show - -instance Observable D where - observer (D x) = send "D" $ return D << x - constrain = undefined - -f = observe "f" f' -f' x = D x - -main = logO "r0" $ print (f 3) diff --git a/tests/Generic/r1.hs b/tests/Generic/r1.hs deleted file mode 100644 --- a/tests/Generic/r1.hs +++ /dev/null @@ -1,16 +0,0 @@ -import Debug.Hoed.Pure - -data D = D D | C Int - deriving Show - -instance Observable D where - observer (D x) = send "D" $ return D << x - observer (C i) = send "C" $ return C << i - constrain = undefined - -f :: D -> Int -f = observe "f" f' -f' (C x) = x -f' (D d) = f d - -main = logO "r0" $ print (f (D (C 3))) diff --git a/tests/Generic/r2.hs b/tests/Generic/r2.hs deleted file mode 100644 --- a/tests/Generic/r2.hs +++ /dev/null @@ -1,16 +0,0 @@ -import Debug.Hoed.Pure - -data D = D D | T - deriving (Show) - -instance Observable D where - observer (D x) = send "D" $ return D << x - observer T = send "T" $ return T - constrain = undefined - -f :: D -> Int -f = observe "f" f' -f' T = 1 -f' (D _) = 0 - -main = logO "r0" $ print (f (D (D (D T)))) diff --git a/tests/Generic/r3.hs b/tests/Generic/r3.hs deleted file mode 100644 --- a/tests/Generic/r3.hs +++ /dev/null @@ -1,16 +0,0 @@ -import Debug.Hoed.Pure - -data Expr = Mul Expr Expr | Const Int | Exc - deriving Show - -instance Observable Expr where - observer (Mul e1 e2) = send "Mul" $ return Mul << e1 << e2 - observer (Const v) = send "Const" $ return Const << v - observer Exc = send "Exc" $ return Exc - constrain = undefined - -one = observe "one" one' -one' (Mul expr (Const 1)) = expr -one' expr = expr - -main = logO "g" $ print $ one (Mul (Const 1) (Const 1)) diff --git a/tests/Generic/t0.hs b/tests/Generic/t0.hs deleted file mode 100644 --- a/tests/Generic/t0.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -import Debug.Hoed.Pure - -data D = D Int - deriving (Show,Generic) - -instance Observable D - -f = observe "f" f' -f' x = D x - -main = logO "t0" $ print (f 3) diff --git a/tests/Generic/t1.hs b/tests/Generic/t1.hs deleted file mode 100644 --- a/tests/Generic/t1.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -import Debug.Hoed.Pure - -data D = D D | C Int - deriving (Show,Generic) - -instance Observable D - -f :: D -> Int -f = observe "f" f' -f' (C x) = x -f' (D d) = f d - -main = logO "r0" $ print (f (D (C 3))) diff --git a/tests/Generic/t2.hs b/tests/Generic/t2.hs deleted file mode 100644 --- a/tests/Generic/t2.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -import Debug.Hoed.Pure - -data D = D D | T - deriving (Show,Generic) - -instance Observable D - -f :: D -> Int -f = observe "f" f' -f' T = 1 -f' (D _) = 0 - -main = logO "r0" $ print (f (D (D (D T)))) diff --git a/tests/Generic/t3.hs b/tests/Generic/t3.hs deleted file mode 100644 --- a/tests/Generic/t3.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -import Debug.Hoed.Pure - -data Expr = Mul Expr Expr | Const Int | Exc - deriving (Show,Generic) - -instance Observable Expr - -one = observe "one" one' -one' (Mul expr (Const 1)) = expr -one' expr = expr - -main = logO "g" $ print $ one (Mul (Const 1) (Const 1)) diff --git a/tests/Prop/t0/Main.hs b/tests/Prop/t0/Main.hs deleted file mode 100644 --- a/tests/Prop/t0/Main.hs +++ /dev/null @@ -1,19 +0,0 @@ --- A program with unexpected output. - -import MyModule -import Debug.Hoed.Pure - --- main = quickcheck prop_idemSimplify -main = logOwp Bottom "hoed-tests-Prop-t0.graph" properties $ print $ prop_idemSimplify (Mul (Const 1) (Const 2)) - where - properties = [ Propositions [mkProposition myModule "prop_idemOne" - `ofType` BoolProposition - `withSignature` [Argument 0]] PropertiesOf "one" [] - , Propositions [mkProposition myModule "prop_idemZero" - `ofType` BoolProposition - `withSignature` [Argument 0]] PropertiesOf "zero" [] - , Propositions [mkProposition myModule "prop_idemSimplify" - `ofType` BoolProposition - `withSignature` [Argument 0]] PropertiesOf "simplify" [] - ] - myModule = Module "MyModule" "../Prop/t0/" diff --git a/tests/Prop/t1/Main.hs b/tests/Prop/t1/Main.hs deleted file mode 100644 --- a/tests/Prop/t1/Main.hs +++ /dev/null @@ -1,16 +0,0 @@ --- A program with unexpected output. -import CNF -import Debug.Hoed.Pure - --- main = quickcheck prop_idem_negin_sound -main = logOwp Bottom "hoed-tests-Prop-t1.graph" properties $ print (prop_negin_correct eg) --- main = logOwp "hoed-tests-Prop-t1.graph" properties $ print (negin eg, prop_negin_correct eg) - where - properties = [Propositions - [ mkProposition cnfModule "prop_negin_complete" - `ofType` BoolProposition `withSignature` [Argument 0] - , mkProposition cnfModule "prop_negin_sound" - `ofType` BoolProposition `withSignature` [Argument 0] - ] Specify "negin" [] - ] - cnfModule = Module "CNF" "../Prop/t1/" diff --git a/tests/Prop/t2/Main.hs b/tests/Prop/t2/Main.hs deleted file mode 100644 --- a/tests/Prop/t2/Main.hs +++ /dev/null @@ -1,15 +0,0 @@ --- A program with unexpected output. -import Digraph -import Debug.Hoed.Pure - --- main = quickcheck prop_idem_negin_sound -main = logOwp Bottom "hoed-tests-Prop-t2.graph" properties $ print (prop_assoc1toNdigraph eg) - where - properties = [ Propositions [mkProposition digraphModule "prop_assoc1toNdigraph" - `ofType` BoolProposition `withSignature` [Argument 0]] Specify "assoc1toNdigraph" [] - , Propositions [mkProposition digraphModule "prop_mergeAndSortTargets" - `ofType` BoolProposition `withSignature` [Argument 0]] Specify "mergeAndSortTargets" [] - , Propositions [mkProposition digraphModule "prop_addMissingSources" - `ofType` BoolProposition `withSignature` [Argument 0]] Specify "addMissingSources" [] - ] - digraphModule = Module "Digraph" "../Prop/t2/" diff --git a/tests/Prop/t3/Main.hs b/tests/Prop/t3/Main.hs deleted file mode 100644 --- a/tests/Prop/t3/Main.hs +++ /dev/null @@ -1,250 +0,0 @@ -import Properties -import Debug.Hoed.Pure -import System.Environment -import Text.Printf -import Control.Monad -import System.Random -import Test.QuickCheck -import Data.Maybe -import XMonad.StackSet -import qualified Data.Map as M - -myStackSet = (StackSet {current = Screen {workspace = Workspace {tag = NonNegative 4, layout = 8, stack = Just (Stack {focus = 'v', up = "hyimlnxj", down = "z"})}, screen = 0, screenDetail = 6}, visible = [Screen {workspace = Workspace {tag = NonNegative 0, layout = 8, stack = Nothing}, screen = 1, screenDetail = 7},Screen {workspace = Workspace {tag = NonNegative 2, layout = 8, stack = Just (Stack {focus = 'a', up = "", down = "s"})}, screen = 2, screenDetail = 3},Screen {workspace = Workspace {tag = NonNegative 3, layout = 8, stack = Just (Stack {focus = 'u', up = "", down = "wdrg"})}, screen = 3, screenDetail = 9},Screen {workspace = Workspace {tag = NonNegative 4, layout = 8, stack = Just (Stack {focus = 'j', up = "", down = "xnlmiyhvz"})}, screen = 0, screenDetail = 6},Screen {workspace = Workspace {tag = NonNegative 1, layout = 8, stack = Nothing}, screen = 1, screenDetail = 7},Screen {workspace = Workspace {tag = NonNegative 2, layout = 8, stack = Nothing}, screen = 2, screenDetail = 3},Screen {workspace = Workspace {tag = NonNegative 3, layout = 8, stack = Nothing}, screen = 3, screenDetail = 9}], hidden = [Workspace {tag = NonNegative 1, layout = 8, stack = Just (Stack {focus = 'e', up = "", down = "btk"})}], floating = M.fromList []}) - - -main :: IO () -main = logOwp Bottom "hoed-tests-Prop-t3.graph" propositions $ do --- main = do - -{- Running all tests - args <- fmap (drop 1) getArgs - let n = if null args then 100 else read (head args) - (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests - printf "Passed %d tests!\n" (sum passed) - when (not . and $ results) $ fail "Not all tests passed!" --} - - g <- newStdGen; print . fromJust . ok . (generate 1 g) . evaluate $ prop_focusWindow_master (NonNegative 3) (StackSet {current = Screen {workspace = Workspace {tag = NonNegative 0, layout = -4, stack = Just (Stack {focus = 'r', up = "ay", down = ""})}, screen = 0, screenDetail = 0}, visible = [], hidden = [], floating = M.fromList []}) - --- g <- newStdGen; print . fromJust . ok . (generate 1 g) . evaluate $ prop_greedyView_idem myStackSet (NonNegative 4) - - - -{- This is an example of a failing case of prop_greedyView. However, it seems prop_view does not have enough information to judge the child statements as wrong. - - g <- newStdGen; print . fromJust . ok . (generate 1 g) . evaluate $ prop_greedyView_reversible (NonNegative 1) (StackSet {current = Screen {workspace = Workspace {tag = NonNegative 4, layout = 2, stack = Nothing}, screen = 0, screenDetail = 2}, visible = [Screen {workspace = Workspace {tag = NonNegative 1, layout = 2, stack = Just (Stack {focus = 'f', up = "", down = "oda"})}, screen = 1, screenDetail = 0},Screen {workspace = Workspace {tag = NonNegative 2, layout = 2, stack = Just (Stack {focus = 'w', up = "", down = "n"})}, screen = 2, screenDetail = 1},Screen {workspace = Workspace {tag = NonNegative 3, layout = 2, stack = Just (Stack {focus = 't', up = "", down = "e"})}, screen = 3, screenDetail = -1}], hidden = [Workspace {tag = NonNegative 4, layout = 2, stack = Nothing},Workspace {tag = NonNegative 5, layout = 2, stack = Nothing},Workspace {tag = NonNegative 6, layout = 2, stack = Nothing},Workspace {tag = NonNegative 7, layout = 2, stack = Nothing},Workspace {tag = NonNegative 8, layout = 2, stack = Nothing}], floating = M.fromList []}) - --} - - - where - propositions = - [Propositions [mkProposition module_Properties "prop_focus_all_l" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0] - ,mkProposition module_Properties "prop_focus_all_l_weak" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0] - ] - PropertiesOf "focusUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - , Propositions [ mkProposition module_Properties "prop_insert_duplicate_weak" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - ] - PropertiesOf "insertUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - , Propositions [ mkProposition module_Properties "prop_view_reversible" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - , mkProposition module_Properties "prop_view_I" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - , mkProposition module_Properties "prop_view_current" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - , mkProposition module_Properties "prop_view_idem" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0, Argument 1] - , mkProposition module_Properties "prop_view_local" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0, Argument 1] - ] - PropertiesOf "view" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - , Propositions [ mkProposition module_Properties "prop_greedyView_reversible" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - , mkProposition module_Properties "prop_greedyView_idem" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0, Argument 1] - ] - PropertiesOf "greedyView" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - ] - - module_Properties = Module "Properties" "../Prop/t3/" - module_StackSet = Module "XMonad.StackSet" "../Prop/t3/" - module_QuickCheck = Module "Test.QuickCheck" "../Prop/t3/" - module_Map = Module "qualified Data.Map as M" "" - module_Random = Module "System.Random" "" - module_Maybe = Module "Data.Maybe" "" - - tests = - [ ("focusWindow works" , mytest prop_focusWindow_works) - ,("focusWindow is local", mytest prop_focusWindow_local) - ,("focusWindow identity", mytest prop_focusWindow_identity) - ,("focusWindow: invariant", mytest prop_focus_I) - ,("focusWindow master" , mytest prop_focusWindow_master) - ] - -{- - [("StackSet invariants" , mytest prop_invariant) - - ,("empty: invariant" , mytest prop_empty_I) - ,("empty is empty" , mytest prop_empty) - ,("empty / current" , mytest prop_empty_current) - ,("empty / member" , mytest prop_member_empty) - - ,("view : invariant" , mytest prop_view_I) - ,("view sets current" , mytest prop_view_current) - ,("view idempotent" , mytest prop_view_idem) - ,("view reversible" , mytest prop_view_reversible) --- ,("view / xinerama" , mytest prop_view_xinerama) - ,("view is local" , mytest prop_view_local) - - ,("greedyView : invariant" , mytest prop_greedyView_I) - ,("greedyView sets current" , mytest prop_greedyView_current) - ,("greedyView is safe " , mytest prop_greedyView_current_id) - ,("greedyView idempotent" , mytest prop_greedyView_idem) - ,("greedyView reversible" , mytest prop_greedyView_reversible) - ,("greedyView is local" , mytest prop_greedyView_local) --- --- ,("valid workspace xinerama", mytest prop_lookupWorkspace) - - ,("peek/member " , mytest prop_member_peek) - - ,("index/length" , mytest prop_index_length) - - ,("focus left : invariant", mytest prop_focusUp_I) - ,("focus master : invariant", mytest prop_focusMaster_I) - ,("focus right: invariant", mytest prop_focusDown_I) - ,("focusWindow: invariant", mytest prop_focus_I) - ,("focus left/master" , mytest prop_focus_left_master) - ,("focus right/master" , mytest prop_focus_right_master) - ,("focus master/master" , mytest prop_focus_master_master) - ,("focusWindow master" , mytest prop_focusWindow_master) - ,("focus left/right" , mytest prop_focus_left) - ,("focus right/left" , mytest prop_focus_right) - ,("focus all left " , mytest prop_focus_all_l) - ,("focus all right " , mytest prop_focus_all_r) - ,("focus down is local" , mytest prop_focus_down_local) - ,("focus up is local" , mytest prop_focus_up_local) - ,("focus master is local" , mytest prop_focus_master_local) - ,("focus master idemp" , mytest prop_focusMaster_idem) - - ,("focusWindow is local", mytest prop_focusWindow_local) - ,("focusWindow works" , mytest prop_focusWindow_works) - ,("focusWindow identity", mytest prop_focusWindow_identity) - - ,("findTag" , mytest prop_findIndex) - ,("allWindows/member" , mytest prop_allWindowsMember) - ,("currentTag" , mytest prop_currentTag) - - ,("insert: invariant" , mytest prop_insertUp_I) - ,("insert/new" , mytest prop_insert_empty) - ,("insert is idempotent", mytest prop_insert_idem) - ,("insert is reversible", mytest prop_insert_delete) - ,("insert is local" , mytest prop_insert_local) - ,("insert duplicates" , mytest prop_insert_duplicate) - ,("insert/peek " , mytest prop_insert_peek) - ,("insert/size" , mytest prop_size_insert) - - ,("delete: invariant" , mytest prop_delete_I) - ,("delete/empty" , mytest prop_empty) - ,("delete/member" , mytest prop_delete) - ,("delete is reversible", mytest prop_delete_insert) - ,("delete is local" , mytest prop_delete_local) - ,("delete/focus" , mytest prop_delete_focus) - ,("delete last/focus up", mytest prop_delete_focus_end) - ,("delete ~last/focus down", mytest prop_delete_focus_not_end) - - ,("filter preserves order", mytest prop_filter_order) - - ,("swapMaster: invariant", mytest prop_swap_master_I) - ,("swapUp: invariant" , mytest prop_swap_left_I) - ,("swapDown: invariant", mytest prop_swap_right_I) - ,("swapMaster id on focus", mytest prop_swap_master_focus) - ,("swapUp id on focus", mytest prop_swap_left_focus) - ,("swapDown id on focus", mytest prop_swap_right_focus) - ,("swapMaster is idempotent", mytest prop_swap_master_idempotent) - ,("swap all left " , mytest prop_swap_all_l) - ,("swap all right " , mytest prop_swap_all_r) - ,("swapMaster is local" , mytest prop_swap_master_local) - ,("swapUp is local" , mytest prop_swap_left_local) - ,("swapDown is local" , mytest prop_swap_right_local) - - ,("shiftMaster id on focus", mytest prop_shift_master_focus) - ,("shiftMaster is local", mytest prop_shift_master_local) - ,("shiftMaster is idempotent", mytest prop_shift_master_idempotent) - ,("shiftMaster preserves ordering", mytest prop_shift_master_ordering) - - ,("shift: invariant" , mytest prop_shift_I) - ,("shift is reversible" , mytest prop_shift_reversible) - ,("shiftWin: invariant" , mytest prop_shift_win_I) - ,("shiftWin is shift on focus" , mytest prop_shift_win_focus) - ,("shiftWin fix current" , mytest prop_shift_win_fix_current) - - ,("floating is reversible" , mytest prop_float_reversible) - ,("floating sets geometry" , mytest prop_float_geometry) - ,("floats can be deleted", mytest prop_float_delete) - ,("screens includes current", mytest prop_screens) - - ,("differentiate works", mytest prop_differentiate) - ,("lookupTagOnScreen", mytest prop_lookup_current) - ,("lookupTagOnVisbleScreen", mytest prop_lookup_visible) - ,("screens works", mytest prop_screens_works) - ,("renaming works", mytest prop_rename1) - ,("ensure works", mytest prop_ensure) - ,("ensure hidden semantics", mytest prop_ensure_append) - - ,("mapWorkspace id", mytest prop_mapWorkspaceId) - ,("mapWorkspace inverse", mytest prop_mapWorkspaceInverse) - ,("mapLayout id", mytest prop_mapLayoutId) - ,("mapLayout inverse", mytest prop_mapLayoutInverse) - - -- testing for failure: - ,("abort fails", mytest prop_abort) - ,("new fails with abort", mytest prop_new_abort) - ,("shiftWin identity", mytest prop_shift_win_indentity) - - -- tall layout - - ,("tile 1 window fullsize", mytest prop_tile_fullscreen) - ,("tiles never overlap", mytest prop_tile_non_overlap) - ,("split hozizontally", mytest prop_split_hoziontal) - ,("split verticalBy", mytest prop_splitVertically) - - ,("pure layout tall", mytest prop_purelayout_tall) - ,("send shrink tall", mytest prop_shrink_tall) - ,("send expand tall", mytest prop_expand_tall) - ,("send incmaster tall", mytest prop_incmaster_tall) - - -- full layout - - ,("pure layout full", mytest prop_purelayout_full) - ,("send message full", mytest prop_sendmsg_full) - ,("describe full", mytest prop_desc_full) - - ,("describe mirror", mytest prop_desc_mirror) - - -- resize hints - ,("window hints: inc", mytest prop_resize_inc) - ,("window hints: inc all", mytest prop_resize_inc_extra) - ,("window hints: max", mytest prop_resize_max) - ,("window hints: max all ", mytest prop_resize_max_extra) - - ] --} - - diff --git a/tests/Prop/t4/Main.hs b/tests/Prop/t4/Main.hs deleted file mode 100644 --- a/tests/Prop/t4/Main.hs +++ /dev/null @@ -1,245 +0,0 @@ -import Properties -import Debug.Hoed.Pure -import System.Environment -import Text.Printf -import Control.Monad -import System.Random -import Test.QuickCheck -import Data.Maybe -import XMonad.StackSet -import qualified Data.Map as M - -myStackSet :: T -myStackSet = StackSet {current = Screen {workspace = Workspace {tag = NonNegative 2, layout = -2, stack = Just (Stack {focus = 'c', up = "", down = "z"})}, screen = 2, screenDetail = 1}, visible = [Screen {workspace = Workspace {tag = NonNegative 0, layout = -2, stack = Just (Stack {focus = 'd', up = "", down = ""})}, screen = 1, screenDetail = -2},Screen {workspace = Workspace {tag = NonNegative 3, layout = -2, stack = Just (Stack {focus = 'v', up = "", down = ""})}, screen = 3, screenDetail = -1},Screen {workspace = Workspace {tag = NonNegative 4, layout = -2, stack = Just (Stack {focus = 'w', up = "", down = "i"})}, screen = 0, screenDetail = -2}], hidden = [Workspace {tag = NonNegative 1, layout = -2, stack = Just (Stack {focus = 'n', up = "", down = ""})},Workspace {tag = NonNegative 0, layout = -2, stack = Nothing},Workspace {tag = NonNegative 4, layout = -2, stack = Nothing}], floating = M.fromList []} - - - -{- Running all tests -main = do - args <- fmap (drop 1) getArgs - let n = if null args then 100 else read (head args) - (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests - printf "Passed %d tests!\n" (sum passed) - when (not . and $ results) $ fail "Not all tests passed!" --} - -main :: IO () -main = logOwp Bottom "hoed-tests-Prop-t4.graph" propositions $ do - g <- newStdGen - print . fromJust . ok . (generate 1 g) . evaluate $ prop_shift_win_I 1 'd' myStackSet - where - propositions = - [Propositions [mkProposition module_Properties "prop_focus_all_l" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0] - ,mkProposition module_Properties "prop_focus_all_l_weak" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0] - ] - PropertiesOf "focusUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - , Propositions [ mkProposition module_Properties "prop_insert_duplicate_weak" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - ] - PropertiesOf "insertUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - , Propositions [ mkProposition module_Properties "prop_view_reversible" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - , mkProposition module_Properties "prop_view_I" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - , mkProposition module_Properties "prop_view_current" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - , mkProposition module_Properties "prop_view_idem" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0, Argument 1] - , mkProposition module_Properties "prop_view_local" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0, Argument 1] - ] - PropertiesOf "view" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - , Propositions [ mkProposition module_Properties "prop_greedyView_reversible" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 1, Argument 0] - , mkProposition module_Properties "prop_greedyView_idem" - `ofType` LegacyQuickCheckProposition - `withSignature` [Argument 0, Argument 1] - ] - PropertiesOf "greedyView" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe] - - ] - - module_Properties = Module "Properties" "../Prop/t4/" - module_StackSet = Module "XMonad.StackSet" "../Prop/t4/" - module_QuickCheck = Module "Test.QuickCheck" "../Prop/t4/" - module_Map = Module "qualified Data.Map as M" "" - module_Random = Module "System.Random" "" - module_Maybe = Module "Data.Maybe" "" - - tests = - [("shiftMaster id on focus", mytest prop_shift_master_focus) - -- ,("shiftMaster is local", mytest prop_shift_master_local) - -- ,("shiftMaster is idempotent", mytest prop_shift_master_idempotent) - -- ,("shiftMaster preserves ordering", mytest prop_shift_master_ordering) - - -- ,("shift: invariant" , mytest prop_shift_I) - -- ,("shift is reversible" , mytest prop_shift_reversible) - ,("shiftWin: invariant" , mytest prop_shift_win_I) - ,("shiftWin is shift on focus" , mytest prop_shift_win_focus) - ,("shiftWin fix current" , mytest prop_shift_win_fix_current) - ] - -{- - [("StackSet invariants" , mytest prop_invariant) - - ,("empty: invariant" , mytest prop_empty_I) - ,("empty is empty" , mytest prop_empty) - ,("empty / current" , mytest prop_empty_current) - ,("empty / member" , mytest prop_member_empty) - - ,("view : invariant" , mytest prop_view_I) - ,("view sets current" , mytest prop_view_current) - ,("view idempotent" , mytest prop_view_idem) - ,("view reversible" , mytest prop_view_reversible) --- ,("view / xinerama" , mytest prop_view_xinerama) - ,("view is local" , mytest prop_view_local) - - ,("greedyView : invariant" , mytest prop_greedyView_I) - ,("greedyView sets current" , mytest prop_greedyView_current) - ,("greedyView is safe " , mytest prop_greedyView_current_id) - ,("greedyView idempotent" , mytest prop_greedyView_idem) - ,("greedyView reversible" , mytest prop_greedyView_reversible) - ,("greedyView is local" , mytest prop_greedyView_local) --- --- ,("valid workspace xinerama", mytest prop_lookupWorkspace) - - ,("peek/member " , mytest prop_member_peek) - - ,("index/length" , mytest prop_index_length) - - ,("focus left : invariant", mytest prop_focusUp_I) - ,("focus master : invariant", mytest prop_focusMaster_I) - ,("focus right: invariant", mytest prop_focusDown_I) - ,("focusWindow: invariant", mytest prop_focus_I) - ,("focus left/master" , mytest prop_focus_left_master) - ,("focus right/master" , mytest prop_focus_right_master) - ,("focus master/master" , mytest prop_focus_master_master) - ,("focusWindow master" , mytest prop_focusWindow_master) - ,("focus left/right" , mytest prop_focus_left) - ,("focus right/left" , mytest prop_focus_right) - ,("focus all left " , mytest prop_focus_all_l) - ,("focus all right " , mytest prop_focus_all_r) - ,("focus down is local" , mytest prop_focus_down_local) - ,("focus up is local" , mytest prop_focus_up_local) - ,("focus master is local" , mytest prop_focus_master_local) - ,("focus master idemp" , mytest prop_focusMaster_idem) - - ,("focusWindow is local", mytest prop_focusWindow_local) - ,("focusWindow works" , mytest prop_focusWindow_works) - ,("focusWindow identity", mytest prop_focusWindow_identity) - - ,("findTag" , mytest prop_findIndex) - ,("allWindows/member" , mytest prop_allWindowsMember) - ,("currentTag" , mytest prop_currentTag) - - ,("insert: invariant" , mytest prop_insertUp_I) - ,("insert/new" , mytest prop_insert_empty) - ,("insert is idempotent", mytest prop_insert_idem) - ,("insert is reversible", mytest prop_insert_delete) - ,("insert is local" , mytest prop_insert_local) - ,("insert duplicates" , mytest prop_insert_duplicate) - ,("insert/peek " , mytest prop_insert_peek) - ,("insert/size" , mytest prop_size_insert) - - ,("delete: invariant" , mytest prop_delete_I) - ,("delete/empty" , mytest prop_empty) - ,("delete/member" , mytest prop_delete) - ,("delete is reversible", mytest prop_delete_insert) - ,("delete is local" , mytest prop_delete_local) - ,("delete/focus" , mytest prop_delete_focus) - ,("delete last/focus up", mytest prop_delete_focus_end) - ,("delete ~last/focus down", mytest prop_delete_focus_not_end) - - ,("filter preserves order", mytest prop_filter_order) - - ,("swapMaster: invariant", mytest prop_swap_master_I) - ,("swapUp: invariant" , mytest prop_swap_left_I) - ,("swapDown: invariant", mytest prop_swap_right_I) - ,("swapMaster id on focus", mytest prop_swap_master_focus) - ,("swapUp id on focus", mytest prop_swap_left_focus) - ,("swapDown id on focus", mytest prop_swap_right_focus) - ,("swapMaster is idempotent", mytest prop_swap_master_idempotent) - ,("swap all left " , mytest prop_swap_all_l) - ,("swap all right " , mytest prop_swap_all_r) - ,("swapMaster is local" , mytest prop_swap_master_local) - ,("swapUp is local" , mytest prop_swap_left_local) - ,("swapDown is local" , mytest prop_swap_right_local) - - ,("shiftMaster id on focus", mytest prop_shift_master_focus) - ,("shiftMaster is local", mytest prop_shift_master_local) - ,("shiftMaster is idempotent", mytest prop_shift_master_idempotent) - ,("shiftMaster preserves ordering", mytest prop_shift_master_ordering) - - ,("shift: invariant" , mytest prop_shift_I) - ,("shift is reversible" , mytest prop_shift_reversible) - ,("shiftWin: invariant" , mytest prop_shift_win_I) - ,("shiftWin is shift on focus" , mytest prop_shift_win_focus) - ,("shiftWin fix current" , mytest prop_shift_win_fix_current) - - ,("floating is reversible" , mytest prop_float_reversible) - ,("floating sets geometry" , mytest prop_float_geometry) - ,("floats can be deleted", mytest prop_float_delete) - ,("screens includes current", mytest prop_screens) - - ,("differentiate works", mytest prop_differentiate) - ,("lookupTagOnScreen", mytest prop_lookup_current) - ,("lookupTagOnVisbleScreen", mytest prop_lookup_visible) - ,("screens works", mytest prop_screens_works) - ,("renaming works", mytest prop_rename1) - ,("ensure works", mytest prop_ensure) - ,("ensure hidden semantics", mytest prop_ensure_append) - - ,("mapWorkspace id", mytest prop_mapWorkspaceId) - ,("mapWorkspace inverse", mytest prop_mapWorkspaceInverse) - ,("mapLayout id", mytest prop_mapLayoutId) - ,("mapLayout inverse", mytest prop_mapLayoutInverse) - - -- testing for failure: - ,("abort fails", mytest prop_abort) - ,("new fails with abort", mytest prop_new_abort) - ,("shiftWin identity", mytest prop_shift_win_indentity) - - -- tall layout - - ,("tile 1 window fullsize", mytest prop_tile_fullscreen) - ,("tiles never overlap", mytest prop_tile_non_overlap) - ,("split hozizontally", mytest prop_split_hoziontal) - ,("split verticalBy", mytest prop_splitVertically) - - ,("pure layout tall", mytest prop_purelayout_tall) - ,("send shrink tall", mytest prop_shrink_tall) - ,("send expand tall", mytest prop_expand_tall) - ,("send incmaster tall", mytest prop_incmaster_tall) - - -- full layout - - ,("pure layout full", mytest prop_purelayout_full) - ,("send message full", mytest prop_sendmsg_full) - ,("describe full", mytest prop_desc_full) - - ,("describe mirror", mytest prop_desc_mirror) - - -- resize hints - ,("window hints: inc", mytest prop_resize_inc) - ,("window hints: inc all", mytest prop_resize_inc_extra) - ,("window hints: max", mytest prop_resize_max) - ,("window hints: max all ", mytest prop_resize_max_extra) - - ] --} - - diff --git a/tests/Prop/t5/Main.hs b/tests/Prop/t5/Main.hs deleted file mode 100644 --- a/tests/Prop/t5/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Even - -main = doit diff --git a/tests/Pure/t1.hs b/tests/Pure/t1.hs deleted file mode 100644 --- a/tests/Pure/t1.hs +++ /dev/null @@ -1,12 +0,0 @@ -import Debug.Hoed.Pure - -f :: Int -> Int -f = observe "f" f' -f' x = if x > 0 then g x else 0 - -g :: Int -> Int -g = observe "g" g' -g' x = x `div` 2 - -main = logO "hoed-tests-Pure-t1.graph" $ print ((f 2) + (f 0)) - diff --git a/tests/Pure/t2.hs b/tests/Pure/t2.hs deleted file mode 100644 --- a/tests/Pure/t2.hs +++ /dev/null @@ -1,19 +0,0 @@ -import Debug.Hoed.Pure - -k :: Int -> Int -k = observe "k" k' -k' x = (l x) + (m $ x + 1) - -l :: Int -> Int -l = observe "l" l' -l' x = m x - -m :: Int -> Int -m = observe "m" m' -m' x = n x - -n :: Int -> Int -n = observe "n" n' -n' x = x - -main = logO "hoed-tests-Pure-t2.graph" $ print (k 1) diff --git a/tests/Pure/t3.hs b/tests/Pure/t3.hs deleted file mode 100644 --- a/tests/Pure/t3.hs +++ /dev/null @@ -1,22 +0,0 @@ --- Haskell version of the buggy insertion sort as shown in Lee Naish --- A Declarative Debugging Scheme. - -{-# LANGUAGE StandaloneDeriving #-} -import Debug.Hoed.Pure - --- Insertion sort. -isort :: [Int] -> [Int] -isort = observe "isort" isort' -isort' [] = [] -isort' (n:ns) = insert n (isort ns) - --- Insert number into sorted list. -insert :: Int -> [Int] -> [Int] -insert = observe "insert" insert' -insert' :: Int -> [Int] -> [Int] -insert' n [] = [n] -insert' n (m:ms) - | n <= m = n : ms -- bug: `m' is missing in this case - | otherwise = m : (insert n ms) - -main = logO "hoed-tests-Pure-t3.graph" $ print (isort [1,2]) diff --git a/tests/Pure/t4.hs b/tests/Pure/t4.hs deleted file mode 100644 --- a/tests/Pure/t4.hs +++ /dev/null @@ -1,25 +0,0 @@ --- A defective implementation of a parity function with a test property. - -import Debug.Hoed.Pure - -isOdd :: Int -> Bool -isOdd = observe "isOdd" isOdd' -isOdd' n = isEven (plusOne n) - -isEven :: Int -> Bool -isEven = observe "isEven" isEven' -isEven' n = mod2 n == 0 - -plusOne :: Int -> Int -plusOne = observe "plusOne" plusOne' -plusOne' n = n + 1 - -mod2 :: Int -> Int -mod2 = observe "mod2" mod2' -mod2' n = div n 2 - -prop_isOdd :: Int -> Bool -prop_isOdd x = isOdd (2*x+1) - -main :: IO () -main = logO "hoed-tests-Pure-t4.graph" $ print (prop_isOdd 1) diff --git a/tests/Pure/t5.hs b/tests/Pure/t5.hs deleted file mode 100644 --- a/tests/Pure/t5.hs +++ /dev/null @@ -1,13 +0,0 @@ -import Debug.Hoed.Pure - -f :: Maybe Int -> Int -f = observe "f" f' -f' (Just i) = g i -f' Nothing = 0 - -g :: Int -> Int -g = observe "g" g' -g' x = x + x - -main :: IO () -main = logO "hoed-tests-Pure-t5.graph" $ print (f $ Just 3) diff --git a/tests/Pure/t6.hs b/tests/Pure/t6.hs deleted file mode 100644 --- a/tests/Pure/t6.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Main where -import Debug.Hoed.Pure - --- This test demonstrates that using the FPretty library we pretty print --- much bigger computation statements than with the previous implementation --- based on Wadler's "prettier printer". - -data T = Step T | End deriving Generic -instance Observable T - -v :: T -v = foldr (\_ -> Step) End [1..1000] - -ends :: T -> Bool -ends = observe "ends" ends' -ends' (Step t) = ends' t -ends' End = True - -main = logO "hoed-tests-Pure-t6.graph" $ print $ ends v diff --git a/tests/Pure/t7.hs b/tests/Pure/t7.hs deleted file mode 100644 --- a/tests/Pure/t7.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Debug.Hoed.Pure - -plus :: Int -> Int -> Int -plus = {- observe "plus"-} (+) - -apx :: (Int -> Int) -> Int -> Int -apx = {- observe "apx" -} apx' -apx' f x = f x - -apxy :: (Int -> Int -> Int) -> Int -> Int -> Int -apxy = observe "apxy" apxy' -apxy' f x y = f x y - -ap45' :: (Int->Int->Int) -> Int -ap45 = observe "ap45" ap45' -ap45' f = apx (apxy f 4) 5 - -main = logO "hoed-tests-Pure-t7.graph" $ print (ap45 plus) diff --git a/tests/Stk/DoublingServer.hs b/tests/Stk/DoublingServer.hs deleted file mode 100644 --- a/tests/Stk/DoublingServer.hs +++ /dev/null @@ -1,74 +0,0 @@ --- Based on the TrivialServer-example from Marlow, Parallel and Concurrent --- Programming in Haskell - -import System.IO -import Network -import Text.Printf -import Control.Monad -import Control.Concurrent -import Debug.Hoed.Stk(observe,Observable(..),logO,send) -import System.IO.Unsafe -import Data.List - -twotimes :: Integer -> Integer -twotimes j = (observe "twotimes" - ( \i -> {-# SCC "twotimes" #-} - 2 + i -- bug: should be 2 * i - )) j - -double :: String -> String -double = observe "double" - $ \s -> {-# SCC "double" #-} show (twotimes (read s :: Integer)) - -loop h = do - line <- hGetLine h - if line == "end" - then do hPutStrLn h ("Thank you for using the Haskell doubling service.") - putStrLn $ "server: Terminated client " ++ show h - else do hPutStrLn h (double line) - loop h - -talk :: Handle -> IO () -talk h = do - hSetBuffering h LineBuffering - i <- myThreadId - hPutStrLn h $ "Welcome on thread " ++ show i - loop h - -port :: Int -port = 44444 - -server :: Int -> Socket -> IO () -server = observe "server" (\x sock -> {-# SCC "server" #-} server' x sock) - where server' 0 _ = putStrLn "server: Shutting down." - server' x sock = do - (handle, host, port) <- accept sock - printf "server: Accepted connection from %s: %s\n" host (show port) - forkFinally (talk handle) (\_ -> hClose handle) - server (x-1) sock - -client :: Int -> IO () -client x = do - h <- connectTo "localhost" (PortNumber (fromIntegral port)) - hSetBuffering h LineBuffering - let pr s = putStrLn $ "client-" ++ show x ++ ": " ++ s - - s <- hGetLine h; pr s -- Get and print the welcome message - hPutStrLn h (show x) -- Send x for doubling to the server - s <- hGetLine h; pr s -- Get and print response from server - hPutStrLn h "end" -- Send goodbye message - s <- hGetLine h; pr s -- Get and print response from server - -main :: IO () -main = logO "hoed-tests-Stk-DoublingServer.graph" $ withSocketsDo $ do - sock <- listenOn (PortNumber (fromIntegral port)) - printf "server: Listening on port %d.\n" port - forkIO (server 2 sock) -- Start server in own thread. - client 2 -- Connect with two clients from this thread to the server. - client 3 - threadDelay 1000 -- Give server-thread some time to terminate. - -slices = [] - -instance Observable Handle where observer h = send (show h) (return h) -instance Observable Socket where observer s = send "socket" (return s) diff --git a/tests/Stk/Example1.hs b/tests/Stk/Example1.hs deleted file mode 100644 --- a/tests/Stk/Example1.hs +++ /dev/null @@ -1,9 +0,0 @@ -import Debug.Hoed.Stk - -f :: Int -> Int -f = observe "f" $ \x -> {-# SCC "f" #-} if x > 0 then g x else 0 - -g :: Int -> Int -g = observe "g" $ \x -> {-# SCC "g" #-} x `div` 2 - -main = logO "hoed-tests-Stk-Example1.graph" $ print ((f 2) + (f 0)) diff --git a/tests/Stk/Example3.lhs b/tests/Stk/Example3.lhs deleted file mode 100644 --- a/tests/Stk/Example3.lhs +++ /dev/null @@ -1,27 +0,0 @@ -> {-# LANGUAGE TemplateHaskell, Rank2Types #-} -> import Debug.Hoed.Stk - -> $(observedTypes "k" []) -> $(observedTypes "l" []) -> $(observedTypes "m" []) -> $(observedTypes "n" []) - - -> main = logO "hoed-tests-Stk-Example3.graph" $ print (k 1) - -> k :: Int -> Int -> k x = $(observeTempl "k") k' x -> k' x = {-# SCC "k" #-} k'' x -> k'' x = (l x) + (m $ x + 1) - -> l :: Int -> Int -> l x = $(observeTempl "l") l' x -> l' x = {-# SCC "l" #-} m x - -> m :: Int -> Int -> m x = $(observeTempl "m") m' x -> m' x = {-# SCC "m" #-} n x - -> n :: Int -> Int -> n x = $(observeTempl "n") n' x -> n' x = {-# SCC "n" #-} x diff --git a/tests/Stk/Example4.hs b/tests/Stk/Example4.hs deleted file mode 100644 --- a/tests/Stk/Example4.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Debug.Hoed.Stk - -main = logO "hoed-tests-Stk-Example4.graph" $ print (observe "main" $ 42 :: Int) diff --git a/tests/Stk/IndirectRecursion.lhs b/tests/Stk/IndirectRecursion.lhs deleted file mode 100644 --- a/tests/Stk/IndirectRecursion.lhs +++ /dev/null @@ -1,37 +0,0 @@ -This is an example of how information is lost as a result of trunction of the -cost centre stack. The actual call graph is of this program is: - - main -> f 1 -> g 2 -> f 3 -> h 1 - -But with pushing "f" a second time the "g" label is also lost. Additionally -the h-statement is associated with the stack [f], which can either be from the -untruncated f statement or the truncated f statement. We therefore infer the -following call graph: - - main -> f 1 -> {f 3, g 2} -> h 1 - \_________________^ - -> {-# LANGUAGE TemplateHaskell, Rank2Types #-} -> import Debug.Hoed.Stk - -> $(observedTypes "f" []) -> $(observedTypes "g" []) -> $(observedTypes "h" []) - -> f :: Int -> Int -> f x = $(observeTempl "f") f' x -> f' x = {-# SCC "f" #-} f'' x -> f'' 1 = g 2 -> f'' x = h (x + 1) - -> g :: Int -> Int -> g x = $(observeTempl "g") g' x -> g' x = {-# SCC "g" #-} g'' x -> g'' x = f (x + 1) - -> h :: Int -> Int -> h x = $(observeTempl "h") h' x -> h' x = {-# SCC "h" #-} h'' x -> h'' x = (x+1) - -> main = logO "hoed-tests-Stk-IndirectRecursion.graph" $ print (f 1) diff --git a/tests/Stk/Insort2.hs b/tests/Stk/Insort2.hs deleted file mode 100644 --- a/tests/Stk/Insort2.hs +++ /dev/null @@ -1,39 +0,0 @@ --- Haskell version of the buggy insertion sort as shown in Lee Naish --- A Declarative Debugging Scheme. --- --- As Insort1, but with observe rather than templated observers. - -{-# LANGUAGE StandaloneDeriving #-} -import Debug.Hoed.Stk - --- Insertion sort. - -isort :: [Int] -> [Int] -isort ns = observe "isort" (\ns -> {-# SCC "isort" #-} isort' ns) ns -isort' [] = [] -isort' (n:ns) = insert n (isort ns) - --- Insert number into sorted list. - -insert :: Int -> [Int] -> [Int] -insert n ms = (observe "insert" (\n ms -> {-# SCC "insert" #-} insert' n ms)) n ms -insert' :: Int -> [Int] -> [Int] -insert' n [] = [n] -insert' n (m:ms) - | n <= m = n : ms -- bug: `m' is missing in this case - | otherwise = m : (insert n ms) - -main = logO "hoed-tests-Stk-Insort2.graph" . print $ - (observe "result") ({-# SCC "result" #-} isort [1,2]) - --- Slices, these should be generated automatically from the original code. - -slices - = [ ("result", "isort [1,2]") - , ("isort" , "isort [] = []\n" - ++ "isort (n:ns) = insert n (isort ns)") - , ("insert", " insert n [] = [n]\n" - ++ " insert n (m:ms)\n" - ++ " | n <= m = n : ms\n" - ++ " | otherwise = m : (insert n ms)\n") - ]