packages feed

Hoed 0.3.0 → 0.3.1

raw patch · 67 files changed

+2390/−2335 lines, 67 filesdep +FPrettydep +X11dep +deepseqdep ~basedep ~libgraphdep ~threepenny-guinew-component:exe:hoed-examples-Expression_simplifiernew-component:exe:hoed-examples-Expression_simplifier__with_propertiesnew-component:exe:hoed-examples-FPretty_indents_too_muchnew-component:exe:hoed-examples-FPretty_indents_too_much__CCnew-component:exe:hoed-examples-Insertion_Sort_elements_disappearnew-component:exe:hoed-examples-Parity_testnew-component:exe:hoed-examples-Simple_higher-order_functionnew-component:exe:hoed-examples-SummerSchool_compiler_does_not_terminatenew-component:exe:hoed-examples-XMonad_changing_focus_duplicates_windowsnew-component:exe:hoed-examples-XMonad_changing_focus_duplicates_windows__CCnew-component:exe:hoed-examples-XMonad_changing_focus_duplicates_windows__using_propertiesnew-component:exe:hoed-tests-Prop-t0new-component:exe:hoed-tests-Prop-t1new-component:exe:hoed-tests-Prop-t2new-component:exe:hoed-tests-Prop-t3new-component:exe:hoed-tests-Prop-t4new-component:exe:hoed-tests-Pure-t5new-component:exe:hoed-tests-Pure-t6new-component:exe:hoed-tests-Pure-t7binary-added

Dependencies added: FPretty, X11, deepseq, extensible-exceptions, lazysmallcheck, random, unix, utf8-string

Dependency ranges changed: base, libgraph, threepenny-gui

Files

Debug/Hoed/Pure.hs view
@@ -96,16 +96,29 @@   ( -- * Basic annotations     observe   , runO+  , testO   , printO+  , logO +  -- * Property-based judging+  , runOwp+  , testOwp+  , logOwp+  , Propositions(..)+  , PropType(..)+  , Proposition(..)+  , PropositionType(..)+  , Module(..)+     -- * Experimental annotations   , traceOnly-  , doit   , observeTempl   , observedTypes   , observeCC-  , logO +   -- * Parallel equality+  , ParEq(..)+    -- * The Observable class   , Observer(..)   , Observable(..)@@ -127,9 +140,11 @@ import Debug.Hoed.Pure.CompTree import Debug.Hoed.Pure.DemoGUI import Debug.Hoed.Pure.Prop+import Paths_Hoed(getDataDir)  import Prelude hiding (Right) import qualified Prelude+import System.Process(system) import System.IO import Data.Maybe import Control.Monad@@ -169,17 +184,6 @@         ; endEventStream         } --- | run some code and return the CDS structure (for when you want to write your own debugger).-debugO' :: IO a -> IO [CDS]-debugO' program = do-  events <- debugO program-  return (eventsToCDS events)----- | print a string, with debugging-putStrO :: String -> IO ()-putStrO expr = runO (putStr 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.@@ -193,10 +197,40 @@  runO :: IO a -> IO () runO program = do-  (trace,traceInfo,compGraph,frt) <- runO' program-  debugSession trace traceInfo compGraph frt+  (trace,traceInfo,compTree,frt) <- runO' program+  debugSession trace traceInfo compTree frt   return () +-- | 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' program+  hPutStrLn stderr "\n=== Evaluating assigned properties ===\n"+  compTree' <- judge trace ps compTree++  let vs = filter (/= RootVertex) (vertices compTree')+      showLen p = show . length . (filter p) $ vs+  hPutStrLn stderr "\n=== Evaluated assigned properties for all computation statements ==="+  hPutStrLn stderr $ showLen isWrong    ++ " statements are now wrong because they fail a property."+  hPutStrLn stderr $ showLen isAssisted ++ " statements satisfy some properties and violate no properties."+  hPutStrLn stderr $ showLen isRight    ++ " statements are right because they satisfy their specification."+  case (findFaulty_dag getJudgement compTree') of+    []    -> do hPutStrLn stderr "\n=== Starting interactive debug session ===\n"+                debugSession trace traceInfo compTree' frt+    (v:_) -> hPutStrLn stderr $ "Fault detected in:\n\n" ++ show (vertexStmt v)+  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)@@ -207,46 +241,32 @@   debugO program   return () -doit :: IO a -> IO ()-doit program = do-  (trace,traceInfo,compGraph,frt) <- runO' program-  case filter (/= RootVertex) (vertices compGraph) of-    []    -> return ()-    (v:_) -> do putStrLn "\n=== DoIt ===\n"-                v' <- judge trace p1 v-                print v'  runO' :: IO a -> IO (Trace,TraceInfo,CompTree,EventForest) runO' program = do   createDirectoryIfMissing True ".Hoed/"-  hPutStrLn stderr "=== program output ===\n"+  putStrLn "=== program output ===\n"   events <- debugO program+  putStrLn "\n=== program terminated ==="+  putStrLn "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-      rs   = filter isRootEvent events       ti   = traceInfo (reverse events)       ds   = dependencies ti       ct   = mkCompTree eqs ds -  -- hPutStrLn stderr "\n=== Events ===\n"-  -- hPutStrLn stderr $ unlines (map show . reverse $ events)-  writeFile ".Hoed/Events" (unlines . map show . reverse $ events)--  -- hPutStrLn stderr "\n=== Dependencies ===\n"-  -- hPutStrLn stderr $ unlines (map (\(m,n,msg) -> show m ++ " -> " ++ show n ++ " %" ++ msg) ds)--  -- hPutStrLn stderr "\n=== Computation Statements ===\n"-  -- hPutStrLn stderr $ show eqs-  -- hPutStrLn stderr $ unlines . (map $ show . stmtUIDs) $ eqs-+  writeFile ".Hoed/Events"     (unlines . map show . reverse $ events)+  writeFile ".Hoed/Transcript" (getTranscript events ti)+     hPutStrLn stderr "\n=== Statistics ===\n"   let e  = length events       n  = length eqs-      d  = treeDepth ct+      -- d  = treeDepth ct       b  = fromIntegral (length . arcs $ ct ) / fromIntegral ((length . vertices $ ct) - (length . leafs $ ct))   hPutStrLn stderr $ "e = " ++ show e   hPutStrLn stderr $ "n = " ++ show n@@ -257,13 +277,7 @@   -- hPutStrLn stderr "\n=== Debug Session ===\n"   return (events, ti, ct, frt) -  where summarizeEvent e = show (eventUID e) ++ ": " ++ summarizeChange (change e)-        summarizeChange (Observe l _ _) = show l-        summarizeChange (Cons _ c)      = show c-        summarizeChange c               = show c-        showJ (Just s) = show s-        showJ Nothing  = "??"-+-- | Trace and write computation tree to file. Useful for regression testing. logO :: FilePath -> IO a -> IO () logO filePath program = {- SCC "logO" -} do   (_,_,compTree,_) <- runO' program@@ -271,39 +285,25 @@   return ()    where showGraph g        = showWith g showVertex showArc-        showVertex RootVertex = ("root","")+        showVertex RootVertex = ("\".\"","shape=none")         showVertex v       = ("\"" ++ (escape . showCompStmt) v ++ "\"", "")         showArc _          = ""         showCompStmt       = show . vertexStmt --hPutStrList :: (Show a) => Handle -> [a] -> IO()-hPutStrList h []     = hPutStrLn h ""-hPutStrList h (c:cs) = do {hPutStrLn h (show c); hPutStrList h cs}----------------------------------------------------------------------------- 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)+-- | As logO, but with property-based judging.+logOwp :: FilePath -> [Propositions] -> IO a -> IO ()+logOwp filePath properties program = do+  (trace,traceInfo,compTree,frt) <- runO' program+  hPutStrLn stderr "\n=== Evaluating assigned properties ===\n"+  compTree' <- judge 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@@ -311,6 +311,8 @@ debugSession :: Trace -> TraceInfo -> CompTree -> EventForest -> IO () debugSession trace traceInfo tree frt   = do createDirectoryIfMissing True ".Hoed/wwwroot/css"+       dataDir <- getDataDir+       system $ "cp " ++ dataDir ++ "/img/*png .Hoed/wwwroot/"        treeRef <- newIORef tree        startGUI defaultConfig            { jsPort       = Just 10000
Debug/Hoed/Pure/CompTree.hs view
@@ -8,12 +8,21 @@ , mkCompTree , isRootVertex , vertexUID+, vertexRes+, getJudgement+, setJudgement+, isRight+, isWrong+, isUnassessed+, isAssisted , leafs , ConstantValue(..) , getLocation , getMessage+, getTranscript , TraceInfo(..) , traceInfo+, Graph(..) -- re-export from LibGraph )where  import Debug.Hoed.Pure.Render@@ -28,13 +37,30 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet -data Vertex = RootVertex | Vertex {vertexStmt :: CompStmt, vertexJmt :: Judgement} +data Vertex = RootVertex | Vertex {vertexStmt :: CompStmt, vertexJmt :: Judgement}   deriving (Eq,Show,Ord) +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+ vertexUID :: Vertex -> UID vertexUID RootVertex   = -1 vertexUID (Vertex s _) = stmtIdentifier s +vertexRes :: Vertex -> String+vertexRes RootVertex = "RootVertex"+vertexRes v          = stmtRes . vertexStmt $ v+ type CompTree = Graph Vertex ()  isRootVertex :: Vertex -> Bool@@ -81,9 +107,9 @@ instance Show ConstantValue where   show CVRoot = "Root"   show v = "Stmt-" ++ (show . valStmt $ v)-         ++ "-"    ++ (show . valLoc  $ v) -         ++ ": "   ++ (show . valMin  $ v) -         ++ "-"    ++ (show . valMax  $ v) +         ++ "-"    ++ (show . valLoc  $ v)+         ++ ": "   ++ (show . valMin  $ v)+         ++ "-"    ++ (show . valMax  $ v)  ------------------------------------------------------------------------------------------------------------------------ @@ -125,6 +151,17 @@    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+++ ------------------------------------------------------------------------------------------------------------------------  getLocation :: Event -> TraceInfo -> Bool@@ -200,8 +237,8 @@   where i  = getTopLvlFun e s         cs = deleteFirst (computations s)         m  = addMessage e $ "Stop computation " ++ show i ++ ": " ++ showCs cs-        deleteFirst [] = [] -        deleteFirst (s:ss) | isSpan i s = ss +        deleteFirst [] = []+        deleteFirst (s:ss) | isSpan i s = ss                            | otherwise  = s : deleteFirst ss  @@ -209,25 +246,25 @@ pause e s = m s{computations=cs}    where i  = getTopLvlFun e s-        cs = map pause' (computations 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         m  = addMessage e $ "Pause computation " ++ show i ++ ": " ++ showCs cs -        pause' (Computing j) | i == j    = Paused i-                             | otherwise = Computing j-        pause' s = s-- resume :: Event -> TraceInfo -> TraceInfo resume e s = m s{computations=cs}    where i  = getTopLvlFun e s-        cs = map resume' (computations s)-        m  = addMessage e $ "Resume computation " ++ show i ++ ": " ++ showCs cs--        resume' (Paused j)   | i == j    = Computing i-                             | otherwise = Paused j-        resume' s = 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+        m = addMessage e $ "Resume computation " ++ show i ++ ": " ++ showCs cs  activeComputations :: TraceInfo -> [UID] activeComputations s = map getSpanUID . filter isActive $ computations s@@ -276,36 +313,29 @@ traceInfo trc = foldl loop s0 trc    where s0 :: TraceInfo-        s0 = TraceInfo IntMap.empty IntMap.empty [] IntMap.empty IntMap.empty [] +        s0 = TraceInfo IntMap.empty IntMap.empty [] IntMap.empty IntMap.empty []          cs :: ConsMap         cs = mkConsMap trc -        is :: IntSet-        is = foldl (\s e -> case change e of Cons{} -> IntSet.insert (eventUID e) s; _ -> s) IntSet.empty trc--        parentIsConstant :: Event -> Bool-        parentIsConstant e = IntSet.member (parentUID . eventParent $ e) is-         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) +                        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 +                        Enter{}   -> if not . corToCons cs $ e then s else cpyTopLvlFun e                                      $ case loc of-                                          True  -> (if parentIsConstant e then id else addDependency e) +                                          True  -> addDependency e                                                    $ start e s                                           False -> pause e s                          -- Span end-                        Cons{} ->  cpyTopLvlFun e +                        Cons{} ->  cpyTopLvlFun e                                    . setLocation e (\_->loc)-                                   $ case loc of +                                   $ case loc of                                        True  -> stop e s                                        False -> resume e s
Debug/Hoed/Pure/DemoGUI.hs view
@@ -3,23 +3,27 @@ -- Copyright (c) Maarten Faddegon, 2014-2015 {-# LANGUAGE CPP #-} -module Debug.Hoed.Pure.DemoGUI+module Debug.Hoed.Pure.DemoGUI (guiMain, noNewlines) 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 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.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.List(intersperse,nub,sort,sortBy+import Data.List(findIndex,intersperse,nub,sort,sortBy #if __GLASGOW_HASKELL__ >= 710                 , sortOn #endif@@ -37,27 +41,28 @@ -- The tabbed layout from which we select the different views  guiMain :: Trace -> TraceInfo -> IORef CompTree ->  EventForest -> Window -> UI ()-guiMain trace traceInfo treeRef frt window+guiMain trace traceInfo compTreeRef frt window   = do return window # set UI.title "Hoed debugging session"         -- Get a list of vertices from the computation graph-       tree <- UI.liftIO $ readIORef treeRef+       tree <- UI.liftIO $ readIORef compTreeRef        let ns = filter (not . isRootVertex) (preorder tree)         -- Shared memory-       filteredVerticesRef <- UI.liftIO $ newIORef ns        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 "Help"                  # set UI.style activeTab+       tab1 <- UI.button # set UI.text "About Hoed"            # 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 "Events"                # set UI.style otherTab-       tabs <- UI.div    # set UI.style [("background-color","#D3D3D3")]  #+ (map return [tab1,tab2,tab3,tab4])+       tab3 <- UI.button # set UI.text "Algorithmic Debugging" # set UI.style otherTab+       tab4 <- UI.button # set UI.text "Explore"               # set UI.style otherTab+       -- tab5 <- UI.button # set UI.text "Events"                # 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-},logo]) -       let coloActive tab = do mapM_ (\t -> t # set UI.style otherTab) [return tab1,return tab2,return tab3,return tab4]; return tab # set UI.style activeTab+       let coloActive tab = do mapM_ (\t -> (return t) # set UI.style otherTab) [tab1,tab2,tab3,tab4{-,tab5-}]; return tab # set UI.style activeTab         help <- guiHelp # set UI.style [("margin-top","0.5em")]        on UI.click tab1 $ \_ -> do@@ -65,16 +70,20 @@             UI.getBody window # set UI.children [tabs,help]        on UI.click tab2 $ \_ -> do             coloActive tab2-            pane <- guiObserve treeRef currentVertexRef # set UI.style [("margin-top","0.5em")]+            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 <- guiAlgoDeb treeRef filteredVerticesRef currentVertexRef regexRef imgCountRef # set UI.style [("margin-top","0.5em")]+            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 <- guiTrace trace traceInfo # set UI.style [("margin-top","0.5em")]-         UI.getBody window # set UI.children [tabs,pane]+            coloActive tab4+            pane <- guiExplore 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 <- guiTrace trace traceInfo # set UI.style [("margin-top","0.5em")]+       --   UI.getBody window # set UI.children [tabs,pane]         UI.getBody window # set UI.style [("margin","0")] #+ (map return [tabs,help])        return ()@@ -82,57 +91,29 @@  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", "19px"),("-webkit-border-top-right-radius", "19"), ("-moz-border-top-right-radius", "19"), ("border-top-right-radius", "19px"), ("border-width", "medium medium 0px")]+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"+  [ 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 trace is translated into a tree of computation statements for the algorithmic debugging view. 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."+  , 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 page showing the list of events in the trace--guiTrace :: Trace -> TraceInfo -> UI UI.Element-guiTrace trace traceInfo = do-  rows <- mapM (\e -> eventRow e traceInfo) (reverse trace)-  tbl  <- UI.table #+ map return rows-  UI.span #+ [return tbl]--eventRow :: Event -> TraceInfo -> UI UI.Element-eventRow e traceInfo = do-  sign <- UI.td # set UI.text (let sym = case getLocation e traceInfo of True  -> "* "; False -> "o "-                               in case change e of-                                    Observe{} -> " "-                                    Fun{}     -> " "-                                    Enter{}   -> sym-                                    Cons{}    -> sym)-  evnt <- UI.td # set UI.text (show e)-  msg <- UI.td # set UI.text (getMessage e traceInfo)-  UI.tr #+ map return [sign,evnt,msg]--getStk :: Event -> TraceInfo -> String-getStk e traceInfo = case change e of-  Enter{}  -> case IntMap.lookup (eventUID e) (storedStack traceInfo) of -              (Just stk) -> show stk-              Nothing    -> ""-  _        -> ""----------------------------------------------------------------------------------- -- The observe GUI  guiObserve :: IORef CompTree -> IORef Int -> UI UI.Element-guiObserve treeRef currentVertexRef = do-       (Graph _ vs _) <- UI.liftIO $ readIORef treeRef+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@@ -141,58 +122,127 @@            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-       div1 <- UI.div #+ spans         -- Alphabetical sorted list of computation statements-       let vs_sorted = sortOn (stmtRes . vertexStmt) . filter (not . isRootVertex) $ vs-       div3 <- UI.form # set UI.style [("margin-left","2em")]-       updateRegEx currentVertexRef vs_sorted div3 "" -- with empty regex to fill div3 1st time+       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-       on UI.valueChange matchField (updateRegEx currentVertexRef vs_sorted div3)-       div2 <- UI.div # set UI.style [("float","right")] # set UI.text "filter " #+ [return matchField]+       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 -       hr <- UI.hr-       UI.div  #+ map return [div1,hr,div2,div3]+       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 = draw+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 draw = do (return stmtDiv) # set UI.children [] #+ csDivs; 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 -> (stmtRes . vertexStmt) v =~ r) vs-        ss = map (stmtRes . vertexStmt) vs_filtered+  vs_filtered = if r == "" then vs else filter (\v -> (noNewlines . vertexRes $ v) =~ r) vs -        csDivs = map stmtToDiv vs_filtered+  csDivs = map stmtToDiv vs_filtered -        stmtToDiv v = do-          i <- UI.liftIO $ readIORef currentVertexRef-          s <- UI.span # set UI.text (stmtRes . vertexStmt $ v)-          r <- UI.input # set UI.type_ "radio" # set UI.checked (i == vertexUID v)-          on UI.checkedChange r $ \_ -> checked v-          UI.div #+ [return r, return s]+  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)+    on UI.checkedChange r $ \_ -> checked v+    UI.div #+ [return r, return s] -        -- MF TODO: instead of re-drawing it would be prettier to just-        -- read out the old value of currentVertexRef and set the appropriate-        -- radio button's checked property to False.-        checked v = do-          UI.liftIO $ writeIORef currentVertexRef (vertexUID v)-          draw+  checked v = do+    UI.liftIO $ writeIORef currentVertexRef (vertexUID v)+    drawR  ----------------------------------------------------------------------------------- The algorithmic debugging GUI+-- The Algorithmic Debugging GUI -guiAlgoDeb :: IORef CompTree -> IORef [Vertex] -> IORef Int -> IORef String -> IORef Int -> UI UI.Element-guiAlgoDeb treeRef filteredVerticesRef currentVertexRef regexRef imgCountRef = do+guiAlgoDebug :: IORef CompTree -> IORef Int -> IORef String -> IORef Int -> UI UI.Element+guiAlgoDebug compTreeRef currentVertexRef regexRef imgCountRef = do +       -- 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+       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 -> UI.Element -> Judgement  -> UI ()+judge advance status compStmt mMenu mImg currentVertexRef compTreeRef b j = +  on UI.click b $ \_ -> do+    mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef compTreeRef+    case mv of+      (Just v) -> judge' status compStmt b j v+      Nothing  -> return ()+  where +  judge' status compStmt b j v = do+      t' <- UI.liftIO $ readIORef compTreeRef+      let t  = markNode t' v j+          v' = setJudgement v j+          w = case (advance, next_step t getJudgement v') of+                (DoNotAdvance,_)           -> v'+                (AdvanceToNext,RootVertex) -> v'+                (AdvanceToNext,w')         -> w'+      UI.liftIO $ writeIORef currentVertexRef (vertexUID w)+      UI.liftIO $ writeIORef compTreeRef t+      UI.element compStmt # UI.set UI.text (show . vertexStmt $ w)+      updateStatus status compTreeRef +      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 treeRef-       let ns = filter (not . isRootVertex) (preorder tree)+       tree <- UI.liftIO $ readIORef compTreeRef         -- Draw the computation graph        img  <- UI.img -       redrawWith img imgCountRef treeRef filteredVerticesRef currentVertexRef+       redrawWith img imgCountRef compTreeRef currentVertexRef        img' <- UI.center #+ [UI.element img]         -- Field to show computation statement(s) of current vertex@@ -200,153 +250,98 @@         -- 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)+       showStmt compStmt compTreeRef currentVertexRef+       updateMenu menu compTreeRef currentVertexRef +       let selectVertex' = selectVertex compStmt menu compTreeRef currentVertexRef (redrawWith img imgCountRef compTreeRef)        on UI.selectionChange menu selectVertex' -       -- Buttons for the various filters-       filterTxt    <- UI.span   # set UI.text "Filters: "-       showAllBut   <- UI.button # set UI.text "Show all"-       showSuccBut  <- UI.button # set UI.text "Show successors"-       showPredBut  <- UI.button # set UI.text "Show predecessors"-       showMatchBut <- UI.button # 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        status <- UI.span-       updateStatus status treeRef +       updateStatus status compTreeRef          -- Buttons to judge the current statement-       right <- UI.button # set UI.text "right"-       wrong <- UI.button # set UI.text "wrong"-       let onJudge = onClick status menu img imgCountRef treeRef -                             currentVertexRef filteredVerticesRef-       onJudge right Right-       onJudge wrong Wrong+       right <- UI.button # UI.set UI.text "right " #+ [UI.img # set UI.src "static/right.png" # set UI.height 20]+       wrong <- UI.button # set UI.text "wrong "    #+ [UI.img # set UI.src "static/wrong.png" # set UI.height 20]+       let j = judge DoNotAdvance status compStmt (Just menu) (Just (img, imgCountRef)) currentVertexRef compTreeRef+       j right Right+       j wrong Wrong         -- Populate the main screen        hr <- UI.hr-       UI.div #+ (map UI.element [filters, menu, right, wrong, status, compStmt, hr,img'])+       br <- UI.br+       UI.div #+ (map UI.element [menu, right, wrong, br, img', br, status, hr, compStmt])   preorder :: CompTree -> [Vertex] preorder = getPreorder . getDfs -showStmt :: UI.Element -> IORef [Vertex] -> IORef Int -> UI ()-showStmt e filteredVerticesRef currentVertexRef = do -  mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef+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  -> "Select vertex above to show details."                 (Just v) -> show . vertexStmt $ v   UI.element e # set UI.text s   return () -data Filter = ShowAll | ShowSucc | ShowPred | ShowMatch--updateMenu :: UI.Element -> IORef CompTree-              -> IORef Int -> IORef [Vertex] -> UI ()-updateMenu menu treeRef currentVertexRef filteredVerticesRef = do-       g  <- UI.liftIO $ readIORef treeRef-       vs <- UI.liftIO $ readIORef filteredVerticesRef+-- 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 = pos (\v -> vertexUID v == i) vs-       let fs = faultyVertices g-       ops  <- mapM (\s->UI.option # set UI.text s)-                                $ if vs == [] then ["No matches found"]-                                  else map (summarizeVertex fs) vs+       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   #+ (map UI.element ops)        (UI.element menu) # set UI.selection (Just j)        return () -pos :: (a->Bool) -> [a] -> Int-pos p xs = case filter (\(_,x) -> p x) $ zip [0..] xs of -                []        -> -1-                ((i,_):_) -> i--vertexFilter :: Filter -> CompTree -> Vertex -> String -> [Vertex]-vertexFilter f g cv r = filter (not . isRootVertex) $ case f of -  ShowAll   -> preorder g-  ShowSucc  -> succs g cv-  ShowPred  -> preds g cv-  ShowMatch -> filter matches (preorder g)-    where matches RootVertex = False-          matches v    = show v =~ r--onClick :: UI.Element -> UI.Element -> UI.Element -           -> IORef Int-> IORef CompTree -> IORef Int -> IORef [Vertex]-           -> UI.Element -> Judgement-> UI ()-onClick status menu img imgCountRef treeRef currentVertexRef filteredVerticesRef b j = do-  on UI.click b $ \_ -> do-        (Just v) <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef-        replaceFilteredVertex v (v{vertexJmt=j})-        updateTree img imgCountRef treeRef (Just v) (\tree -> markNode tree v j)-        updateMenu menu treeRef currentVertexRef filteredVerticesRef-        updateStatus status treeRef+-- 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 () -  where replaceFilteredVertex v w = do-          vs <- UI.liftIO $ readIORef filteredVerticesRef-          UI.liftIO $ writeIORef filteredVerticesRef $ map (\x -> if x == v then w else x) vs+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 []+  return $ filter (/= RootVertex) $ ps ++ sibl ++ (succs t cv) -lookupCurrentVertex :: IORef Int -> IORef [Vertex] -> IO (Maybe Vertex)-lookupCurrentVertex currentVertexRef filteredVerticesRef = do-  i  <- readIORef currentVertexRef-  vs <- readIORef filteredVerticesRef-  return $ case filter (\v->vertexUID v==i) vs of+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" -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 vs <- UI.liftIO $ readIORef filteredVerticesRef-                      let v = vs !! i-                      UI.liftIO $ writeIORef currentVertexRef (vertexUID v)-                      showStmt compStmt filteredVerticesRef currentVertexRef-                      myRedraw filteredVerticesRef currentVertexRef -                      return ()-        Nothing -> return ()---onClickFilter :: UI.Element -> IORef CompTree -> 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 . isRootVertex) . 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 :: CompTree -> Vertex -> Judgement -> CompTree markNode g v s = mapGraph f g   where f RootVertex = RootVertex-        f v'         = if v' === v then v{vertexJmt=s} else v'+        f v'         = if v' === v then setJudgement v s else v'          (===) :: Vertex -> Vertex -> Bool-        v1 === v2 = (vertexStmt v1) == (vertexStmt v2)+        v1 === v2 = (vertexUID v1) == (vertexUID v2)  data MaxStringLength = ShorterThan Int | Unlimited @@ -357,79 +352,96 @@           | 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')+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  summarizeVertex :: [Vertex] -> Vertex -> String--- summarizeVertex fs v = shorten (ShorterThan 27) (noNewlines . show . vertexStmt $ v) ++ s-summarizeVertex fs v = (noNewlines . show . vertexStmt $ v) ++ s-  where s = if v `elem` fs then " !!" else case vertexJmt v of-              Unassessed     -> " ??"+summarizeVertex fs v = shorten (ShorterThan 60) (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 =+  "<<TABLE BORDER=\"0\" CELLBORDER=\"0\"><TR><TD HEIGHT=\"30\" WIDTH=\"30\" FIXEDSIZE=\"true\"><IMG SCALE=\"true\" SRC=\"" ++ (vertexImg fs v) ++ "\"/></TD><TD><FONT POINT-SIZE=\"30\">" ++ (htmlEscape . noNewlines . show . vertexStmt $ v) ++ "</FONT></TD></TR></TABLE>>"++htmlEscape :: String -> String+htmlEscape = foldr (\c acc -> replace c ++ acc) ""+  where+  replace :: Char -> String+  replace '"'  = "&quot;"+  replace '{'  = "&#123;"+  replace '\\' = "&#92;"+  replace '>'  = "&gt;"+  replace '}'  = "&#125;"+  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"+              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 getLabel   = stmtLabel . vertexStmt-      isJudged v = vertexJmt v /= Unassessed+  let isJudged v = getJudgement v /= Unassessed       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: " ++ getLabel (head fs)+      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 () -updateTree :: UI.Element -> IORef Int -> IORef CompTree -> (Maybe Vertex) -> (CompTree -> CompTree)-           -> 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 CompTree -> IORef [Vertex] -> IORef Int -> UI ()-redrawWith img imgCountRef treeRef filteredVerticesRef currentVertexRef = do-  mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef-  redraw img imgCountRef treeRef mv+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 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"+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 g = showWith g (coloVertex $ faultyVertices g) showArc-        coloVertex fs v = ( "\"" ++ (show . vertexUID) v ++ ": "-                            ++ summarizeVertex fs v ++ "\""-                          , if isCurrentVertex mcv v then "style=filled fillcolor=yellow"-                                                     else ""+  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 _  = "" --- 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").-{-+-- Selects current vertex, its predecessor and its successors summarize :: CompTree -> Maybe Vertex -> CompTree-summarize g mcv = Graph (root g) keep as-  where keep1 v = take 7 $ succs g v-        keep'   = nub $ RootVertex : 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)--}+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@@ -440,82 +452,4 @@                 (Just w)          -> vertexStmt v == vertexStmt w  faultyVertices :: CompTree -> [Vertex]-faultyVertices = findFaulty_dag getStatus-  where getStatus RootVertex = Right-        getStatus v    = vertexJmt v-------------------------------------------------------------------------------------- The data flow GUI-{--guiDDT :: ConstantTree -> IORef Int -> EventForest -> IORef Int -> IORef CompTree -> UI UI.Element-guiDDT ddt imgCountRef frt currentVertexRef treeRef = do-  (Graph _ vs _) <- UI.liftIO $ readIORef treeRef-  let idStmts = map (\(Vertex s _) -> (equIdentifier s, s)) . filter (not . isRootVertex) $ vs--  -- The current computation statement-  i  <- UI.liftIO $ readIORef currentVertexRef-  stmtDiv <- UI.div # set UI.text (case lookup i idStmts of -        Nothing  -> "?"-        (Just s) -> equRes s)--  -- Menu to select constant (floating on the right of the page) -  let (Graph _ cs _) = ddt-      cs_i = filter (\c -> case c of CVRoot -> False; _ -> valStmt c == i) cs-  cSel   <- UI.select #+ map (\c -> UI.option # set UI.text (shwConst c)) cs_i-  shwBut <- UI.button # set UI.text "Show me"-  selDiv <- UI.div # set UI.style [("float","right")] #+ [return shwBut, UI.span # set UI.text " where ", return cSel, UI.span # set UI.text " comes from."]--  -- The dynamic data dependency tree-  img <- UI.img-  drawDDT ddt img imgCountRef frt-  centImg <- UI.center #+ [UI.element img]--  UI.div #+ [return selDiv, return stmtDiv, UI.hr, return centImg]--  where shwConst c = shwLoc c ++ "\"" ++ (case lookup (valMax c) es of (Just e) -> render frt e; Nothing -> "?") ++ "\""-        shwLoc c = case (show . valLoc) c of "" -> ""; s -> s ++ ": "-        es = eventsByUID frt--updateStmt :: UI.Element -> IORef Int -> [CompStmt] -> Int -> UI ()-updateStmt stmtDiv currentVertexRef ss pos = do-  let s = ss !! pos-  return stmtDiv # set UI.text (equRes s)-  UI.liftIO $ writeIORef currentVertexRef (equIdentifier s)--drawDDT :: ConstantTree -> UI.Element -> IORef Int -> EventForest -> UI ()-drawDDT ddt img imgCountRef frt = do-  UI.liftIO $ writeFile ".Hoed/dynData.dot" (shw ddt)-  UI.liftIO $ system $ "dot -Tpng -Gsize=9,9 -Gdpi=100 .Hoed/dynData.dot > .Hoed/wwwroot/dynData.png"-  i <- UI.liftIO $ readIORef imgCountRef-  UI.liftIO $ writeIORef imgCountRef (i+1)-  UI.element img # set UI.src ("static/dynData.png#" ++ show i)-  return ()--  where shw g = showWith g shwConst shwArc-        shwConst c = ("Stmt-"++ (show . valStmt) c ++ "-" ++ (show . valLoc) c ++ ": " ++ case lookup (valMax c) es of (Just e) -> render frt e; Nothing -> "?","")-        shwArc _   = ""-        es = eventsByUID frt--eventsByUID :: EventForest -> [(UID,Event)]--- eventsByUID = map (\e -> (eventUID e, e)) . foldl (\acc1 (_,es_p) -> foldl (\acc2 (_,e) -> e : acc2) acc1 es_p) []-eventsByUID = map (\e -> (eventUID e, e)) . map snd . concat . elems--render :: EventForest -> Event -> String-render frt r = dfsFold Infix pre post "" Trunk (Just r) frt-  where pre Nothing  _ = (++" _")-        pre (Just e) _ = case change e of-          (Observe s _ _ _) -> (++s)-          (Cons _ s)        -> (++" ("++s)-          Enter             -> id-          NoEnter           -> id-          Fun               -> (++"{\\")-        post Nothing  _ = id-        post (Just e) _ = case change e of-          (Observe s _ _ _) -> id-          (Cons _ s)        -> (++")")-          Enter             -> id-          NoEnter           -> id-          Fun               -> (++"}")---}+faultyVertices = findFaulty_dag getJudgement
Debug/Hoed/Pure/EventForest.hs view
@@ -57,7 +57,6 @@ 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@@ -69,22 +68,11 @@    show (ResultOf   loc) = 'r' : show loc    show (FieldOf n  loc) = 'f' : show n ++ show loc -data ArgOrRes = Arg | Res---- Is the first location in the argument, or result subtree of the second location?-argOrRes :: Location -> Location -> ArgOrRes-argOrRes (ArgumentOf loc') loc = if loc == loc' then Arg else argOrRes loc' loc-argOrRes (ResultOf loc')   loc = if loc == loc' then Res else argOrRes loc' loc-argOrRes Trunk             _   = error $ "argOrRes: Second location is not on the path"-                                       ++ "between root and the first location."- 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-@@ -101,11 +89,7 @@     Observe{}            -> manyByPosition 0     Fun                  -> manyByPosition 0 ++ manyByPosition 1 -  where -- Find list of events by position-        byPosition :: [ParentPosition] -> [Maybe Event]-        byPosition = map (\pos -> lookup pos cs)--        manyByPosition :: ParentPosition -> [Maybe Event]+  where manyByPosition :: ParentPosition -> [Maybe Event]         manyByPosition pos = case filter (\(pos',_) -> pos == pos') cs of           [] -> [Nothing]           ts -> map (Just . snd) ts
Debug/Hoed/Pure/Observe.lhs view
@@ -44,6 +44,7 @@  \begin{code} module Debug.Hoed.Pure.Observe+{-   (    -- * The main Hood API   @@ -76,7 +77,7 @@   , endEventStream   , ourCatchAllIO   , peepUniq-  ) where+  ) -} where \end{code}  @@ -171,8 +172,10 @@ -- Meta: Selectors 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)+          = M1 (gdmobserver x cxt)+          -- Uncomment next two lines to record selector names+          -- | selName m == "" = M1 (gdmobserver x cxt)+          -- | otherwise       = M1 (send (selName m ++ " =") (gdmObserveChildren x) cxt)         gdmObserveChildren  = gthunk         gdmShallowShow      = error "gdmShallowShow not defined on <<Meta: selectors>>"
Debug/Hoed/Pure/Prop.hs view
@@ -2,104 +2,300 @@ -- -- Copyright (c) Maarten Faddegon, 2015 +{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances, StandaloneDeriving, CPP #-}+ module Debug.Hoed.Pure.Prop where -- ( judge--- , Property(..)+-- , Propositions(..) -- ) where--import Debug.Hoed.Pure.Observe(Trace(..),UID,Event(..),Change(..))+import Debug.Hoed.Pure.Observe(Trace(..),UID,Event(..),Change(..),ourCatchAllIO,evaluate) import Debug.Hoed.Pure.Render(CompStmt(..))-import Debug.Hoed.Pure.CompTree(Vertex(..))+import Debug.Hoed.Pure.CompTree(CompTree,Vertex(..),Graph(..),vertexUID) import Debug.Hoed.Pure.EventForest(EventForest,mkEventForest,dfsChildren)+import Debug.Hoed.Pure.DemoGUI(noNewlines)+import qualified Data.IntMap as M +import qualified Debug.Trace as Debug -- MF TODO+ import Prelude hiding (Right)-import Data.Graph.Libgraph(Judgement(..))+import Data.Graph.Libgraph(Judgement(..),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)+import Data.List(intersperse)+import GHC.Generics hiding (moduleName) --(Generic(..),Rep(..),from,(:+:)(..),(:*:)(..),U1(..),K1(..),M1(..))  ------------------------------------------------------------------------------------------------------------------------ -data Property = Property {moduleName :: String, propertyName :: String, searchPath :: String}+data Propositions = Propositions { propositions :: [Proposition], propType :: PropType, funName :: String+                                 , extraModules :: [Module]+                                 }  +data PropType     = Specify | PropertiesOf++type Proposition  = (PropositionType,Module,String,[Int])++data PropositionType = BoolProposition | QuickCheckProposition++data Module       = Module {moduleName :: String, searchPath :: String}++propositionType :: Proposition -> PropositionType+propositionType (x,_,_,_) = x++propName :: Proposition -> String+propName (_,_,x,_) = x++argMap :: Proposition -> [Int]+argMap (_,_,_,x) = x++propModule :: Proposition -> Module+propModule (_,x,_,_) = x++------------------------------------------------------------------------------------------------------------------------+ sourceFile = ".Hoed/exe/Main.hs"+buildFiles = ".Hoed/exe/Main.o .Hoed/exe/Main.hi" exeFile    = ".Hoed/exe/Main" outFile    = ".Hoed/exe/Main.out"  ------------------------------------------------------------------------------------------------------------------------ -judge' :: ExitCode -> String -> Judgement -> Judgement-judge' (ExitFailure _) _   j = j-judge' ExitSuccess     out j-  | out == "False\n" = Wrong-  | out == "True\n"  = j-  | otherwise     = j+lookupPropositions :: [Propositions] -> Vertex -> Maybe Propositions+lookupPropositions _ RootVertex = Nothing+lookupPropositions ps v = lookupWith funName lbl ps+  where lbl = (stmtLabel . vertexStmt) v -judge :: Trace -> Property -> Vertex -> IO Vertex-judge trc prop v = do+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++------------------------------------------------------------------------------------------------------------------------++judge :: Trace -> [Propositions] -> CompTree -> IO CompTree+judge trc ps compTree = do+  ws <- mapM j vs+  return $ foldl updateTree compTree ws+  where +  vs  = vertices compTree+  j v = case lookupPropositions ps v of +    Nothing  -> return v+    (Just p) -> judgeWithPropositions trc p v+  updateTree compTree w = mapGraph (\v -> if (vertexUID v) == (vertexUID w) then w else v) compTree+++-- Use a property to judge a vertex+judgeWithPropositions :: Trace -> Propositions -> Vertex -> IO Vertex+judgeWithPropositions _ _ RootVertex = return RootVertex+judgeWithPropositions trc p v = do+  mbs <- mapM (evalProposition trc v (extraModules p)) (propositions p)+  let j = case (propType p, any isNothing mbs) of+            (Specify,False) -> if any isJustFalse mbs then Wrong else Right+            _               -> if any isJustFalse mbs then Wrong else Unassessed+      j' = case (j, (map snd) . (filter (isJustTrue . fst)) $ zip mbs (propositions p)) of+             (Unassessed, []) -> Unassessed+             (Unassessed, ps) -> Assisted $ "With passing properties: " ++ commas (map propName ps)+             _                -> j+  hPutStrLn stderr $ "Judgement was " ++ (show . vertexJmt) v ++ ", and is now " ++ show j'+  return v{vertexJmt=j'}+  where+  isJustFalse (Just False) = True+  isJustFalse _            = False+  isJustTrue (Just True)   = True+  isJustTrue _             = False++  commas :: [String] -> String+  commas = concat . (intersperse ", ")+++evalProposition :: Trace -> Vertex -> [Module] -> Proposition -> IO (Maybe Bool)+evalProposition trc v ms prop = do   createDirectoryIfMissing True ".Hoed/exe"-  putStrLn $ "Picked statement identifier = " ++ show i+  hPutStrLn stderr $ "\nEvaluating proposition " ++ propName prop ++ " with statement " ++ (shorten . noNewlines . show . vertexStmt) v+  -- let args = map (\(n,s) -> "Argument " ++ show n ++ ": " ++ s) $ zip [0..] (generateArgs trc getEvent i)+  -- let args = map (\(n,s) -> "Argument " ++ show n ++ ": " ++ (shorten s)) $ zip [0..] (generateArgs trc getEvent i)+  -- hPutStrLn stderr $ "Statement UID = " ++ show i+  -- mapM (hPutStrLn stderr) args+  clean   generateCode   compile   exit' <- compile-  putStrLn $ "Exitted with " ++ show exit'+  hPutStrLn stderr $ "Compilation exitted with " ++ show exit'   exit  <- case exit' of (ExitFailure n) -> return (ExitFailure n)                          ExitSuccess     -> evaluate   out  <- readFile outFile-  putStrLn $ "Exitted with " ++ show exit-  putStrLn $ "Output is " ++ show out-  return v{vertexJmt=judge' exit out (vertexJmt v)}+  hPutStrLn stderr $ "Evaluation exitted with " ++ show exit+  hPutStrLn stderr $ "Output is " ++ show out+  return $ case (exit, out) of+    (ExitFailure _, _)         -> Nothing -- TODO: Can we do better with a failing precondition?+    (ExitSuccess  , "True\n")  -> Just True+    (ExitSuccess  , "False\n") -> Just False+    (ExitSuccess  , _)         -> Nothing -  where generateCode = writeFile sourceFile (generate prop trc i)-        compile      = system $ "ghc -o " ++ exeFile ++ " " ++ sourceFile-        evaluate     = system $ exeFile ++ " &> " ++ outFile-        i            = (stmtIdentifier . vertexStmt) v+    where+    clean        = system $ "rm -f " ++ sourceFile ++ " " ++ exeFile ++ " " ++ buildFiles+    generateCode = do -- Uncomment the next line to dump generated program on screen+                      -- hPutStrLn stderr $ "Generated the following program ***\n" ++ prgm ++ "\n***" +                      writeFile sourceFile prgm+                      where prgm :: String+                            prgm = (generate prop ms trc getEvent i)+    compile      = system $ "ghc  -i" ++ (searchPath . propModule) prop ++ " -o " ++ exeFile ++ " " ++ sourceFile+    evaluate     = system $ exeFile ++ " > " ++ outFile ++ " 2>&1"+    i            = (stmtIdentifier . vertexStmt) v +    shorten s+      | length s < 120 = s+      | otherwise    = (take 117 s) ++ "..."++    getEvent :: UID -> Event+    getEvent j = fromJust $ M.lookup j m+      where m = M.fromList $ map (\e -> (eventUID e, e)) trc++-- The actual logic that changes the judgement of a vertex.+judge1' :: ExitCode -> String -> Judgement -> Judgement+judge1' (ExitFailure _) _   j = j+judge1' ExitSuccess     out j+  | out == "False\n" = Wrong+  | out == "True\n"  = j+  | otherwise     = j++judge1_spec :: ExitCode -> String -> Judgement -> Judgement+judge1_spec (ExitFailure _) _   j = j+judge1_spec ExitSuccess     out j+  | out == "False\n" = Wrong+  | out == "True\n"  = Right+  | otherwise     = j+ ------------------------------------------------------------------------------------------------------------------------ -generate :: Property -> Trace -> UID -> String-generate prop trc i = generateHeading prop ++ generateMain prop trc i+generate :: Proposition -> [Module] -> Trace -> (UID->Event) -> UID -> String+generate prop ms trc getEvent i = generateHeading prop ms ++ generateMain prop trc getEvent i -generateHeading :: Property -> String-generateHeading prop =+generateHeading :: Proposition -> [Module] -> String+generateHeading prop ms =   "-- This file is generated by the Haskell debugger Hoed\n"-  ++ "import " ++ moduleName prop ++ "\n"+  ++ generateImport (propModule prop)+  ++ foldl (\acc m -> acc ++ generateImport m) "" ms -generateMain :: Property -> Trace -> UID -> String-generateMain prop trc i =-  "main = print $ " ++ propertyName prop ++ " " ++ generateArgs trc i ++ "\n"+generateImport :: Module -> String+generateImport m =  "import " ++ (moduleName m) ++ "\n" -generateArgs :: Trace -> UID -> String-generateArgs trc i = case dfsChildren frt e of-  [_,ma,_,_]  -> generateExpr frt ma-  xs          -> error ("generateArgs: dfsChildren (" ++ show e ++ ") = " ++ show xs)+generateMain :: Proposition -> Trace -> (UID->Event) -> UID -> String+generateMain prop trc getEvent i =+  foldl (\acc x -> acc ++ " " ++ getArg x) ("main = " ++ generatePrint prop ++ " $ " ++ propName prop ++ " ") (reverse . argMap $ prop) ++ "\n"+  where +  getArg :: Int -> String+  getArg x+    | x < (length args) = args !! x+    | otherwise         = __ +  args :: [String]+  args = generateArgs trc getEvent i++generatePrint :: Proposition -> String+generatePrint p = case propositionType p of+  BoolProposition       -> "print"+  QuickCheckProposition -> "do g <- newStdGen; print . fromJust . ok . (generate 1 g) . evaluate"++generateArgs :: Trace -> (UID -> Event) -> UID -> [String]+generateArgs trc getEvent i = case dfsChildren frt e of+  [_,ma,_,mr]  -> generateExpr frt ma : moreArgs trc getEvent mr+  xs           -> error ("generateArgs: dfsChildren (" ++ show e ++ ") = " ++ show xs)+   where frt = (mkEventForest trc)-        e   = (reverse trc) !! (i-1)+        e   = getEvent i -- (reverse trc) !! (i-1) +moreArgs :: Trace -> (UID->Event) -> Maybe Event -> [String]+moreArgs trc getEvent Nothing = []+moreArgs trc getEvent (Just e)+  | change e == Fun = generateArgs trc getEvent (eventUID e)+  | otherwise       = []+ generateExpr :: EventForest -> Maybe Event -> String generateExpr _ Nothing    = __-generateExpr frt (Just e) = -- enable to add events as comments to generated code: "{- " ++ show e ++ " -}" +++generateExpr frt (Just e) = -- uncomment next line to add events as comments to generated code: +                            -- "{- " ++ show e ++ " -}" ++                             case change e of-  (Cons _ s) -> foldl (\acc c -> acc ++ " " ++ c) ("(" ++ s) cs ++ ") "+  (Cons _ s) -> let s' = if isAlpha (head s) then s else "(" ++ s ++ ")"+                in foldl (\acc c -> acc ++ " " ++ c) ("(" ++ s') cs ++ ") "   Enter      -> ""   _          -> "error \"cannot represent\""    where cs = map (generateExpr frt) (dfsChildren frt e)  __ :: String-__ = "(error \"Request of value that was unevaluated in orignal program.\")"+__ = "(error \"Request of value that was unevaluated in original program.\")"  --------------------------------------------------------------------------------------------------------------------------- Some test data -p1 :: Property-p1 = Property "MyModule" "prop_never" "../Prop"--- p1 = Property "MyModule" "prop_idemSimplify" "../Prop"+class ParEq a where+  (===) :: a -> a -> Maybe Bool+  default (===) :: (Generic a, GParEq (Rep a)) => a -> a -> Maybe Bool+  x === y = gParEq (from x) (from y) -v1 :: Vertex-v1 = Vertex (CompStmt "bla" 1 "bla 3 = 4") Unassessed+class GParEq rep where+  gParEq :: rep a -> rep a -> Maybe Bool -t1, t2 :: IO ()-t1 = print $ generate p1 [] 1-t2 = do {judge [] p1 v1; return ()}+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 === 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 x === y = Just (x == y)+instance ParEq Bool         where x === y = Just (x == y)+instance ParEq Integer      where x === y = Just (x == y)+instance ParEq Float        where x === y = Just (x == y)+instance ParEq Double       where x === y = Just (x == y)+instance ParEq Char         where x === y = Just (x == y)
Debug/Hoed/Pure/Render.hs view
@@ -13,6 +13,7 @@ ) 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@@ -22,10 +23,7 @@                 ) import Data.Graph.Libgraph import Data.Array as Array--head' :: String -> [a] -> a-head' msg [] = error msg-head' _   xs = head xs+import Data.Char(isAlpha)  #if __GLASGOW_HASKELL__ < 710 sortOn :: Ord b => (a -> b) -> [a] -> [a]@@ -66,28 +64,29 @@ -- is rendered to a computation statement  renderCompStmt :: CDS -> [CompStmt]-renderCompStmt (CDSNamed name threadId dependsOn set uids')+renderCompStmt (CDSNamed name threadId dependsOn set)   = map mkStmt statements   where statements :: [(String,UID)]-        statements   = map (\(d,i) -> (pretty 120 d,i)) doc+        statements   = map (\(d,i) -> (pretty 70 d,i)) doc         doc          = foldl (\a b -> a ++ renderNamedTop name b) [] output         output       = cdssToOutput set          mkStmt :: (String,UID) -> CompStmt         mkStmt (s,i) = CompStmt name i s -renderNamedTop :: String -> Output -> [(DOC,UID)]+renderNamedTop :: String -> Output -> [(Doc,UID)] renderNamedTop name (OutData cds)   =  map (\(args,res,Just i) -> (renderNamedFn name (args,res), i)) pairs+  where pairs  = (nubSorted . sortOn argAndRes) pairs'+        pairs' = findFn [cds]+        argAndRes (arg,res,_) = (arg,res) -  where pairs' = findFn [cds]-        pairs  = (nub . sortOn argAndRes) pairs'-        -- local nub for sorted lists-        nub []                  = []-        nub (a:a':as) | a == a' = nub (a' : as)-        nub (a:as)              = a : nub as -        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  -- %************************************************************************ -- %*                                                                   *@@ -96,7 +95,7 @@ -- %************************************************************************  -data CDS = CDSNamed      String ThreadId UID CDSSet [UID]+data CDS = CDSNamed      String ThreadId UID CDSSet          | CDSCons       UID    String   [CDSSet]          | CDSFun        UID             CDSSet CDSSet          | CDSEntered    UID@@ -108,8 +107,6 @@ eventsToCDS :: [Event] -> CDSSet eventsToCDS pairs = getChild 0 0    where-     frt :: EventForest-     frt = mkEventForest pairs       res i = (!) out_arr i @@ -130,12 +127,12 @@      getNode'' node e change =        case change of         (Observe str t i) -> let chd = getChild node 0-                               in CDSNamed str t (getId chd i) chd (treeUIDs frt e)+                               in CDSNamed str t (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 +                            -> CDSCons node cons                                   [ getChild node n | n <- [0..(portc-1)]]       getId []                  i = i@@ -149,9 +146,9 @@         , pport == pport'         ] -render  :: Int -> Bool -> CDS -> DOC+render  :: Int -> Bool -> CDS -> Doc render prec par (CDSCons _ ":" [cds1,cds2]) =-        if (par && not needParen)  +        if (par && not needParen)         then doc -- dont use paren (..) because we dont want a grp here!         else paren needParen doc    where@@ -162,27 +159,41 @@         nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)                             (map renderSet cdss) <>                 text ")")-render prec par (CDSCons _ name cdss) =+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)-              (nest 2-                 (text name <> foldr (<>) nil-                                [ sep <> renderSet' 10 False cds-                                | cds <- cdss -                                ]+                 ( 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 :: CDSSet -> Doc renderSet = renderSet' 0 False -renderSet' :: Int -> Bool -> CDSSet -> DOC+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 <>+renderSet' prec par cdss                   =+         (text "{ " <> foldl1 (\ a b -> a <> line <>                                     text ", " <> b)                                     (map renderFn pairs) <>                 line <> text "}")@@ -196,9 +207,9 @@         nub (a:a':as) | a == a' = nub (a' : as)         nub (a:as)              = a : nub as -renderFn :: ([CDSSet],CDSSet) -> DOC+renderFn :: ([CDSSet],CDSSet) -> Doc renderFn (args, res)-        = grp  (nest 3 +        = grp  (nest 3                 (text "\\ " <>                  foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)                        nil@@ -207,14 +218,12 @@                 )                ) -renderNamedFn :: String -> ([CDSSet],CDSSet) -> DOC+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-            )-        )+  = 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' []@@ -225,17 +234,8 @@        _                -> ([arg], res, Just i) : rest findFn' other rest = ([],[other], Nothing) : rest -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 set us)= CDSNamed str t i (rmEntrySet set) us+rmEntry (CDSNamed str t i set)= CDSNamed str t 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@@ -247,11 +247,11 @@         noEntered _              = True  simplifyCDS :: CDS -> CDS-simplifyCDS (CDSNamed str t i set us) = CDSNamed str t i (simplifyCDSSet set) us-simplifyCDS (CDSCons _ "throw" +simplifyCDS (CDSNamed str t i set) = CDSNamed str t i (simplifyCDSSet set)+simplifyCDS (CDSCons _ "throw"                   [[CDSCons _ "ErrorCall" set]]             ) = simplifyCDS (CDSCons 0 "error" set)-simplifyCDS cons@(CDSCons i str sets) = +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)@@ -260,14 +260,14 @@  simplifyCDS (CDSTerminated i) = (CDSCons i "<?>" []) -simplifyCDSSet = map simplifyCDS +simplifyCDSSet = map simplifyCDS  spotString :: CDSSet -> Maybe String spotString [CDSCons _ ":"                 [[CDSCons _ str []]                 ,rest                 ]-           ] +           ]         = do { ch <- case reads str of                        [(ch,"")] -> return ch                        _ -> Nothing@@ -277,27 +277,18 @@ 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 " "+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) --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 _)+cdsToOutput (CDSNamed name _ _ cdsset)             = OutLabel name res1 res2   where       res1 = [ cdss | (OutData cdss) <- res ]@@ -306,93 +297,9 @@ 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)+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.
Debug/Hoed/Stk.hs view
@@ -50,7 +50,7 @@   , observeCC   , observe'   , Identifier(..)-  ,(*>>=),(>>==),(>>=*)+  -- ,(*>>=),(>>==),(>>=*)   , logO     -- * The Observable class@@ -117,10 +117,6 @@ printO :: (Show a) => a -> IO () printO expr = runO (print expr) --- | print a string, with debugging-putStrO :: String -> IO ()-putStrO expr = runO (putStr 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.@@ -187,11 +183,6 @@         showStk []         = "[]"         showStk stk        = showStk' $ map (\lbl -> "\\\"" ++ lbl ++ "\\\"") stk         showStk' (h:lbls)  = foldl (\lbl acc -> lbl ++ (',' : acc)) ('[' : h) lbls ++ "]"--hPutStrList :: (Show a) => Handle -> [a] -> IO()-hPutStrList h []     = hPutStrLn h ""-hPutStrList h (c:cs) = do {hPutStrLn h (show c); hPutStrList h cs}-  ------------------------------------------------------------------------ -- Push mode option handling
Debug/Hoed/Stk/DemoGUI.hs view
@@ -59,7 +59,7 @@        menu <- UI.select        showStmt compStmt filteredVerticesRef currentVertexRef        updateMenu menu treeRef currentVertexRef filteredVerticesRef-       let selectVertex' = selectVertex compStmt filteredVerticesRef currentVertexRef                                           $ redrawWith img imgCountRef treeRef+       let selectVertex' = selectVertex compStmt filteredVerticesRef currentVertexRef $ redrawWith img imgCountRef treeRef        on UI.selectionChange menu selectVertex'         -- Buttons for the various filters@@ -81,20 +81,20 @@        onClickFilter' showMatchBut ShowMatch         -- Status-       status <- UI.span-       updateStatus status treeRef +       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 status menu img imgCountRef treeRef +       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, status+       UI.getBody window #+ (map UI.element [filters, menu, right, wrong, statusSpan                                             , compStmt, hr,img'])        return () @@ -125,18 +125,21 @@ onClick :: UI.Element -> UI.Element -> UI.Element             -> IORef Int -> IORef CompGraph -> IORef Int -> IORef [Vertex]            -> UI.Element -> Judgement-> UI ()-onClick status menu img imgCountRef treeRef currentVertexRef filteredVerticesRef b j = do+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 (v{status=j})+        replaceFilteredVertex v (newStatus v j)         updateTree img imgCountRef treeRef (Just v) (\tree -> markNode tree v j)         updateMenu menu treeRef currentVertexRef filteredVerticesRef-        updateStatus status treeRef+        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@@ -185,9 +188,10 @@ markNode :: CompGraph -> Vertex -> Judgement -> CompGraph markNode g v s = mapGraph f g   where f Root = Root-        f v'   = if v' === v then v{status=s} else v'+        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@@ -204,11 +208,13 @@ noNewlines = filter (/= '\n')  showCompStmts :: Vertex -> String-showCompStmts = commas . map show . equations-+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 status v of+  where s = if v `elem` fs then " !!" else case getStatus v of               Unassessed     -> " ??"               Wrong          -> " :("               Right          -> " :)"@@ -216,8 +222,9 @@ updateStatus :: UI.Element -> IORef CompGraph -> UI () updateStatus e compGraphRef = do   g <- UI.liftIO $ readIORef compGraphRef-  let getLabel   = commas . (map equLabel) . equations-      isJudged v = status v /= Unassessed+  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@@ -255,7 +262,8 @@        return ()    where shw g = showWith g (coloVertex $ faultyVertices g) showArc-        coloVertex fs v = ( "\"" ++ summarizeVertex fs v ++ "\""+        coloVertex _ Root = ("\".\"", "shape=none")+        coloVertex fs v = ( "\"" ++ escape (summarizeVertex fs v) ++ "\""                           , if isCurrentVertex mcv v then "style=filled fillcolor=yellow"                                                      else ""                           )@@ -281,11 +289,12 @@                 (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) -                     ++ show (last es) ++ "}"+commas es  = foldl (\acc e-> acc ++ e ++ ", ") "{" (init es) ++ (last es) ++ "}"  faultyVertices :: CompGraph -> [Vertex] faultyVertices = findFaulty_dag getStatus-  where getStatus Root = Right-        getStatus v    = status v++getStatus Root = Right+getStatus v    = status v
Debug/Hoed/Stk/Observe.lhs view
@@ -58,7 +58,7 @@     -- * 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@@ -365,13 +365,6 @@  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@@ -404,46 +397,6 @@ 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@@ -494,34 +447,6 @@                 _                  -> 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@@ -728,11 +653,6 @@                 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]@@ -740,31 +660,6 @@  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}  %************************************************************************@@ -868,12 +763,6 @@ %************************************************************************  \begin{code}-type Observing a = a -> a-\end{code}--MF: when do we need this type?--\begin{code} newtype Observer = O (forall a . (Observable a) => String -> a -> a)  -- defaultObservers :: (Observable a) => String -> (Observer -> a) -> a@@ -1076,7 +965,6 @@         { observeParent :: !Int -- my parent         , observePort   :: !Int -- my branch number         } deriving (Show, Read)-root = Parent 0 0 \end{code}  @@ -1295,13 +1183,11 @@  %************************************************************************ -\begin{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-\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
Debug/Hoed/Stk/Render.hs view
@@ -66,13 +66,6 @@         nub (a:a':as) | a == a' = nub (a' : as)         nub (a:as)              = a : nub as -renderCallStack :: CallStack -> DOC-renderCallStack s-  =  text "With call stack: ["-  <> foldl1 (\a b -> a <> text ", " <> b) -            (map text s)-  <> text "]"- ------------------------------------------------------------------------ -- The CompStmt type @@ -126,16 +119,16 @@ nextStack = nextStack_truncate  -- Always push onto top of stack-nextStack_vanilla :: CompStmt -> CallStack-nextStack_vanilla (CompStmt cc _ _ _ _ ccs) = cc:ccs+-- 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+-- 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@@ -148,22 +141,22 @@ 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)+-- 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@@ -293,19 +286,19 @@         nubArcs :: Graph CompStmt () -> Graph CompStmt ()         nubArcs (Graph r vs as) = Graph r vs (nub as) -        sameThread :: Graph CompStmt () -> Graph CompStmt ()-        sameThread (Graph r vs as) = Graph r vs (filter (sameThread') as)-        sameThread' (Arc v w _)-          | equThreadId v == ThreadIdUnknown -            || equThreadId w == ThreadIdUnknown-            || equThreadId v == equThreadId w   = True-          | otherwise                           = False+        -- sameThread :: Graph CompStmt () -> Graph CompStmt ()+        -- sameThread (Graph r vs as) = Graph r vs (filter (sameThread') as)+        -- sameThread' (Arc v w _)+        --   | equThreadId v == ThreadIdUnknown +        --     || equThreadId w == ThreadIdUnknown+        --     || equThreadId v == equThreadId w   = True+        --   | otherwise                           = False -        filterDependsJustOn :: Graph CompStmt () -> Graph CompStmt ()-        filterDependsJustOn (Graph r vs as) = Graph r vs (filter (filterDependsJustOn') as)-        filterDependsJustOn' (Arc v w _) = case equDependsOn w of-          (DependsJustOn i) -> i == equIdentifier v-          _                 -> True+        -- filterDependsJustOn :: Graph CompStmt () -> Graph CompStmt ()+        -- filterDependsJustOn (Graph r vs as) = Graph r vs (filter (filterDependsJustOn') as)+        -- filterDependsJustOn' (Arc v w _) = case equDependsOn w of+        --   (DependsJustOn i) -> i == equIdentifier v+        --   _                 -> True          addSequenceDependencies :: Graph CompStmt () -> Graph CompStmt ()         addSequenceDependencies (Graph r vs as) = Graph r vs (seqDeps vs ++ as)@@ -449,8 +442,6 @@          )  --- This is where the call stacks are merged.--- -- 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 @@ -459,9 +450,12 @@  findFn' (CDSFun _ arg res caller) (rest,_) =     case findFn res of-       ([(args',res')],caller') -> if caller' /= [] && caller' /= caller -                                   then error "found two different stacks!"-                                   else ((arg : args', res') : rest, caller)+       ([(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)
Hoed.cabal view
@@ -1,6 +1,6 @@ name:                Hoed-version:             0.3.0-synopsis:            Lighweight algorithmic debugging.+version:             0.3.1+synopsis:            Lightweight algorithmic debugging. description:     Hoed 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.     .@@ -16,7 +16,8 @@ category:            Debug, Trace build-type:          Simple cabal-version:       >=1.10-Extra-Source-Files:  changelog, README.md+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  flag buildExamples   description: Build example executables.@@ -34,6 +35,10 @@   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@@ -50,18 +55,21 @@                        , Debug.Hoed.Pure.Render                        , Debug.Hoed.Pure.DemoGUI                        , Debug.Hoed.Pure.Prop+                       , Paths_Hoed   build-depends:       base >= 4 && <5                        , template-haskell                        , array, containers                        , process                        , threepenny-gui == 0.6.*                        , filepath-                       , libgraph == 1.5+                       , libgraph == 1.7                        , RBTree == 0.0.5                        , regex-posix                        , mtl                        , directory+                       , FPretty   default-language:    Haskell2010+  -- ghc-options:         -fwarn-unused-binds  --------------------------------------------------------------------------- --@@ -71,58 +79,54 @@ -- --------------------------------------------------------------------------- --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+Executable hoed-examples-FPretty_indents_too_much   if flag(buildExamples)     build-depends:       base >= 4 && < 5                          , Hoed                          , threepenny-gui                          , filepath+                         , containers+                         , deepseq+                         , array   else     buildable: False-  main-is:             HeadOnEmpty.hs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      examples/FPretty   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-HeadOnEmpty2+Executable hoed-examples-FPretty_indents_too_much__CC   if flag(buildExamples)     build-depends:       base >= 4 && < 5                          , Hoed                          , threepenny-gui                          , filepath+                         , containers+                         , deepseq+                         , array   else     buildable: False-  main-is:             HeadOnEmpty2.hs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      examples/FPretty__CC   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+-- 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---   ghc-options:         -O0 -Executable hoed-examples-IndirectRecursion+Executable hoed-examples-Insertion_Sort_elements_disappear   if flag(buildExamples)     build-depends:       base >= 4 && < 5                          , Hoed@@ -130,255 +134,485 @@                          , filepath   else     buildable: False-  main-is:             IndirectRecursion.lhs+  main-is:             Insertion_Sort_elements_disappear.hs   hs-source-dirs:      examples   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-Pretty+Executable hoed-examples-XMonad_changing_focus_duplicates_windows   if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath-                         , array+    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:             Pretty.hs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      examples/XMonad_changing_focus_duplicates_windows   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-Example1+Executable hoed-examples-XMonad_changing_focus_duplicates_windows__CC   if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath+    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:             Example1.hs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      examples/XMonad_changing_focus_duplicates_windows__CC   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+Executable hoed-examples-XMonad_changing_focus_duplicates_windows__using_properties   if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath+    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:             Example3.lhs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      examples/XMonad_changing_focus_duplicates_windows__using_properties   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-Example4+Executable hoed-examples-SummerSchool_compiler_does_not_terminate   if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath+    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:             Example4.hs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      examples/afp02Exercises/Compiler/   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-Insort1+Executable hoed-examples-Simple_higher-order_function   if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath+    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:             Insort.lhs-  hs-source-dirs:      examples+  main-is:             SimpleHO.hs+  hs-source-dirs:      examples/   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-Insort2+Executable hoed-examples-Parity_test   if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath+    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:             Insort2.hs-  hs-source-dirs:      examples+  main-is:             Parity.hs+  hs-source-dirs:      examples/   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-DoublingServer1+Executable hoed-examples-Expression_simplifier   if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath-                         , network+    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:             DoublingServer.hs-  hs-source-dirs:      examples+  main-is:             Main1.hs+  hs-source-dirs:      examples/ExpressionSimplifier   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-DoublingServer2+Executable hoed-examples-Expression_simplifier__with_properties   if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath-                         , network+    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:             DoublingServer2.hs-  hs-source-dirs:      examples+  main-is:             Main2.hs+  hs-source-dirs:      examples/ExpressionSimplifier   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-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 -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+---------------------------------------------------------------------------+--+-- 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-examples-Responsibility-  if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath-                         , array+Executable hoed-tests-Prop-t0+  if flag(validateProp)+    build-depends:     base >= 4 && < 5, Hoed   else     buildable: False-  main-is:             Responsibility.lhs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      tests/Prop/t0   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-TightRope1-  if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath++Executable hoed-tests-Prop-t1+  if flag(validateProp)+    build-depends:     base >= 4 && < 5, Hoed   else     buildable: False-  main-is:             TightRope.hs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      tests/Prop/t1   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-TightRope2-  if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath+Executable hoed-tests-Prop-t2+  if flag(validateProp)+    build-depends:     base >= 4 && < 5, Hoed, lazysmallcheck   else     buildable: False-  main-is:             TightRope2.hs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      tests/Prop/t2   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-TightRope3-  if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath+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:             TightRope3.hs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      tests/Prop/t3   default-language:    Haskell2010-  ghc-options:         -O0 -Executable hoed-examples-AskName-  if flag(buildExamples)-    build-depends:       base >= 4 && < 5-                         , Hoed-                         , threepenny-gui-                         , filepath+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:             AskName.hs-  hs-source-dirs:      examples+  main-is:             Main.hs+  hs-source-dirs:      tests/Prop/t4   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. Reference files are included in--- this repository. To validate execute 'sh test'.---+-- Executable hoed-tests-Prop-t5+--   if flag(validateProp)+--     build-depends:     base >= 4 && < 5, Hoed, +--                        X11>=1.5 && < 1.7, mtl, unix,+--                        utf8-string >= 0.3 && < 0.4,+--                        extensible-exceptions, random,+--                        containers, filepath, process, directory+--   else+--     buildable: False+--   main-is:             Main.hs+--   hs-source-dirs:      tests/Prop/t5+--   default-language:    Haskell2010+ ---------------------------------------------------------------------------  Executable hoed-tests-Generic-r0@@ -496,6 +730,33 @@   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
+ configure.Demo view
@@ -0,0 +1,15 @@++# when not interested in the CC examples the following is enough+#   cabal configure --flags="buildExamples"+# otherwise, the following enables profiling+++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="buildExamples"+else+  cabal configure --enable-profiling --disable-optimization  --flags="buildExamples"+fi
+ configure.Generic view
@@ -0,0 +1,1 @@+cabal configure --flags="validateGeneric"
+ configure.Profiling view
@@ -0,0 +1,1 @@+cabal configure --enable-library-profiling --enable-executable-profiling --flags="buildExamples" --ghc-options="-fprof-auto -fprof-cafs"
+ configure.Prop view
@@ -0,0 +1,1 @@+cabal configure --flags="validateProp" --disable-optimization
+ configure.Pure view
@@ -0,0 +1,1 @@+cabal configure --flags="validatePure"
+ configure.Stk view
@@ -0,0 +1,9 @@+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
− examples/AskName.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}--import Debug.Hoed--data Person = Person { name :: String, age :: Int, city :: String }-  deriving (Show,Generic)--instance Observable Person--main = runO $ observe "main" -        ({-# SCC "main" #-} emptyPerson *>>= getName >>== getAge >>=* getCity >>= print)--emptyPerson :: IO Person-emptyPerson = return (Person "" 0 "")--getName :: Identifier -> (Person -> IO Person, Int)-getName d = let (f,i) = observe' "getName" d (\p' -> {-# SCC "getName" #-} getName' p')-            in (f, i)-getName' p = getLine >>= \x -> return (p{ name = x })--getAge :: Identifier -> (Person -> IO Person, Int)-getAge d = let (f,i) = observe' "getAge" d (\p' -> {-# SCC "getAge" #-} getAge' p')-           in (f, i)-getAge' p = readLn >>= \x -> return (p{ age = x })--getCity :: Identifier -> (Person -> IO Person, Int)-getCity d = let (f,i) = observe' "getCity" d (\p' -> {-# SCC "getCity" #-} getCity' p')-            in (f, i)-getCity' p = getLine >>= \x -> return (p{ city = x })
− examples/DoublingServer.hs 
@@ -1,74 +0,0 @@--- Based on the TrivialServer-example from Marlow, Parallel and Concurrent--- Programming in Haskell--{-# LANGUAGE StandaloneDeriving #-}--import System.IO-import Network-import Text.Printf-import Control.Monad-import Control.Concurrent-import Debug.Hoed(observe,Observable(..),runO,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 s' = observe "double" -            (\s -> {-# SCC "double" #-} show (twotimes (read s :: Integer))) s'--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 = runO $ 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.--instance Observable Handle where observer h = send (show h) (return h)-instance Observable Socket where observer s = send "socket" (return s)
− examples/DoublingServer2.hs 
@@ -1,75 +0,0 @@--- Based on the TrivialServer-example from Marlow, Parallel and Concurrent--- Programming in Haskell--- --{-# LANGUAGE StandaloneDeriving #-}--import System.IO-import Network-import Text.Printf-import Control.Monad-import Control.Concurrent-import Debug.Hoed(observeCC,Observable(..),runO,send)-import System.IO.Unsafe-import Data.List--twotimes :: Integer -> Integer-twotimes j = (observeCC "twotimes"-             ( \i -> {-# SCC "twotimes" #-} -                2 + i -- bug: should be 2 * i-             )) j--double :: String -> String-double s' = observeCC "double" -            (\s -> {-# SCC "double" #-} show (twotimes (read s :: Integer))) s'--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 = observeCC "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 = runO $ 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.--instance Observable Handle where observer h = send (show h) (return h)-instance Observable Socket where observer s = send "socket" (return s)
− examples/DoublingServer3.hs 
@@ -1,74 +0,0 @@--- Based on the TrivialServer-example from Marlow, Parallel and Concurrent--- Programming in Haskell--{-# LANGUAGE StandaloneDeriving #-}--import System.IO-import Network-import Text.Printf-import Control.Monad-import Control.Concurrent-import Debug.Hoed(observe,Observable(..),runO,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 s' = observe "double" -            (\s -> {-# SCC "double" #-} show (twotimes (read s :: Integer))) s'--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 = runO $ observe "main" $ {-# SCC "main" #-} 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.--instance Observable Handle where observer h = send (show h) (return h)-instance Observable Socket where observer s = send "socket" (return s)
− examples/DoublingServer4.hs 
@@ -1,74 +0,0 @@--- Based on the TrivialServer-example from Marlow, Parallel and Concurrent--- Programming in Haskell--{-# LANGUAGE StandaloneDeriving #-}--import System.IO-import Network-import Text.Printf-import Control.Monad-import Control.Concurrent-import Debug.Hoed(observe,observeCC,Observable(..),runO,send)-import System.IO.Unsafe-import Data.List--twotimes :: Integer -> Integer-twotimes j = (observeCC "twotimes"-             ( \i -> {-# SCC "twotimes" #-} -                2 + i -- bug: should be 2 * i-             )) j--double :: String -> String-double s' = observeCC "double" -            (\s -> {-# SCC "double" #-} show (twotimes (read s :: Integer))) s'--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 = observeCC "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 = runO $ observe "main" $ {-# SCC "main" #-} 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.--instance Observable Handle where observer h = send (show h) (return h)-instance Observable Socket where observer s = send "socket" (return s)
− examples/DoublingServer5.hs 
@@ -1,75 +0,0 @@--- Based on the TrivialServer-example from Marlow, Parallel and Concurrent--- Programming in Haskell--{-# LANGUAGE StandaloneDeriving #-}--import System.IO-import Network-import Text.Printf-import Control.Monad-import Control.Concurrent-import Debug.Hoed(observe,Observable(..),runO,send,observe',Identifier(..))-import System.IO.Unsafe-import Data.List--twotimes :: Int -> Integer -> Integer-twotimes d j = (fst $ observe' "twotimes" (DependsJustOn d)-               ( \i -> {-# SCC "twotimes" #-} -                  2 + i -- bug: should be 2 * i-               )) j--double :: String -> String-double s' = let (res,d) = observe' "double" UnknownId-                          (\s -> {-# SCC "double" #-} show (twotimes d (read s :: Integer)))-            in res s'--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 = runO $ 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.--instance Observable Handle where observer h = send (show h) (return h)-instance Observable Socket where observer s = send "socket" (return s)
− examples/Example1.hs 
@@ -1,9 +0,0 @@-import Debug.Hoed--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 = runO $ print ((f 2) + (f 0))
− examples/Example3.lhs 
@@ -1,27 +0,0 @@-> {-# LANGUAGE TemplateHaskell, Rank2Types #-}-> import Debug.Hoed--> $(observedTypes "k" [])-> $(observedTypes "l" [])-> $(observedTypes "m" [])-> $(observedTypes "n" [])---> main = runO $ 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
− examples/Example4.hs 
@@ -1,3 +0,0 @@-import Debug.Hoed--main = runO $ print (observe "main" $ 42 :: Int)
+ examples/ExpressionSimplifier/Main1.hs view
@@ -0,0 +1,6 @@+-- A program with unexpected output.++import MyModule+import Debug.Hoed.Pure++main = testO prop_idemSimplify (Mul (Const 1) (Const 2))
+ examples/ExpressionSimplifier/Main2.hs view
@@ -0,0 +1,13 @@+-- 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 [(BoolProposition,myModule,"prop_idemOne",[0])]      PropertiesOf "one" []+               , Propositions [(BoolProposition,myModule,"prop_idemZero",[0])]     PropertiesOf "zero" []+               , Propositions [(BoolProposition,myModule,"prop_idemSimplify",[0])] PropertiesOf "simplify" []+               ]+  myModule = Module "MyModule" "../examples/ExpressionSimplifier"
+ examples/FPretty/Main.hs view
@@ -0,0 +1,10 @@+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")
+ examples/FPretty__CC/Main.hs view
@@ -0,0 +1,10 @@+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")
− examples/Foldl.hs 
@@ -1,32 +0,0 @@--- Foldl is an example of a higher order function with state (sometimes called--- the accumulator). ------ In this example we demonstrate how a combination of wrapping --- the higher order function "foldl" and transforming the callee "g"--- gives us a notion of order between the callee-observations.--import Prelude hiding (foldl)-import qualified Prelude-import Debug.Hoed(printO,observe,observe',Identifier(..),Observable)---- Prelude.foldl :: (b -> a -> b) -> b [a] -> b--foldl :: (Observable a, Observable b) => ((b,Identifier) -> a -> (b,Int)) -> b -> [a] -> b-foldl fn z = observe "foldl" -               (\xs -> fst $ {-# SCC "foldl" #-} Prelude.foldl fn' (z,UnknownId) xs)-  where fn' a x = let (r,i) = fn a x in (r,InSequenceAfter i)---- g :: Int -> Int -> Int--- g x y = x + y--g :: (Int,Identifier) -> Int -> (Int,Int)-g (a1,id) a2 = let (fn,i) = observe' "g" id (\a1' a2' -> {-# SCC "g" #-} g_orig a1' a2')-               in (fn a1 a2,i)--  where g_orig x y = x + y--f :: [Int] -> Int-f xs = foldl g 10 xs--main :: IO ()-main = printO (f [1,2,3])
− examples/Hashmap.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-import Prelude hiding (lookup,insert)-import Data.Maybe (fromJust)-import Debug.Hoed------------------------------------------------------------------------------------data Hashmap a = Hashmap Int [(Maybe a)] deriving Generic-class Hashable a where hash :: a -> Int--emptyMap :: Int -> Hashmap a-emptyMap size = Hashmap size $ take size (repeat Nothing)--size :: Hashmap a -> Int-size (Hashmap s _) = s--(%) :: Int -> Hashmap a -> Int-idx % hashmap = idx `mod` (size hashmap)--(!!!) :: Hashmap a -> Int -> Maybe a-(!!!) (Hashmap _ elems) = (!!) elems--(///) :: Hashmap a -> (Int,Maybe a) -> Hashmap a-(Hashmap size elems) /// e = Hashmap size (elems // e)--(//) :: [a] -> (Int,a) -> [a]-xs // (idx,x) = take idx xs ++ x : (drop (idx + 1) xs)--add :: (Observable k, Observable v, Hashable k)-    => (k,v) -> Hashmap (k,v) -> Hashmap (k,v)-add (key,elem) hashmap-  = ( -- observe "add"-      (\(key,elem) hashmap -> {-# SCC "add" #-}-        let idx = (hash key) `mod` (size hashmap)-        in insert hashmap idx (key,elem)-      )-    ) (key,elem) hashmap--insert :: Hashmap a -> Int -> a -> Hashmap a-insert hashmap idx x = case hashmap !!! idx of-      Nothing -> hashmap /// (idx,Just x)-      _       -> insert hashmap ((idx+1) % hashmap) x--lookup :: (Observable k, Observable v, Eq k, Hashable k) -       => k -> Hashmap (k,v) -> Maybe (k,v)-lookup key hashmap-  = (observe "lookup"-      (\key hashmap -> {-# SCC "lookup" #-} -        let idx = find hashmap ((hash key) % hashmap) key-        in fmap (\i -> fromJust $ hashmap !!! i) idx-      )-    ) key hashmap--find :: (Observable k, Observable v, Eq k) -     => Hashmap (k,v) -> Int -> k -> Maybe Int-find hashmap idx key -  = ( observe "find"-      (\hashmap idx key -> {-# SCC "find" #-} -        case hashmap !!! idx of-          Nothing            -> Nothing-          (Just (key',elem)) -> if key == key' -                                   then Just idx-                                   else find hashmap ((idx+1) % hashmap) key-      )-    ) hashmap idx key--remove :: (Eq k, Hashable k, Observable k, Observable v)-       => k -> Hashmap (k,v) -> Hashmap (k,v)-remove key hashmap -  = ( observe "remove"-      (\key hashmap -> {-# SCC "remove" #-} -        case find hashmap ((hash key) % hashmap) key of-          Nothing  -> hashmap-          Just idx -> hashmap /// (idx,Nothing)-      )  -    ) key hashmap--instance Observable a => Observable (Hashmap a)-instance Observable Testval-instance Observable Testkey------------------------------------------------------------------------------------data Testkey = One | Two | Three deriving (Eq, Generic)-data Testval = Wennemars | Kramer | Verheijen deriving (Eq, Generic)--main = runO $ print test--instance Hashable Testkey where-        hash One   = 10-        hash Two   = 20-        hash Three = 30--map1 :: Hashmap (Testkey,Testval)-map1 = ( (add (Two, Verheijen))-       . (add (One, Kramer))-       ) (emptyMap 5)----- test = lookup Two map1 == lookup Two (remove One map1)-test = (==) (observe "testLeft" $ {-# SCC "testLeft" #-} lookup Two map1 )-            (observe "testRight" $ {-# SCC "testRight" #-} lookup Two (remove One map1))
− examples/HeadOnEmpty.hs 
@@ -1,12 +0,0 @@-import Debug.Hoed--main = printO x--x :: Int-x = observe "f" ({-# SCC "f" #-} h head xs)--xs :: [Int]-xs = observe "xs" ({-# SCC "xs" #-} [])--h :: ([Int] -> Int) -> [Int] -> Int-h = observe "h" (\a' is' -> {-# SCC "h" #-} a' is')
− examples/HeadOnEmpty2.hs 
@@ -1,21 +0,0 @@-import Debug.Hoed-import GHC.IO(failIO)-import Control.Exception(catch,SomeException)--main = runO $ do-  (print (h xs))     `catch` (handleExc "First one went wrong:")-  ((f xs) >>= print) `catch` (handleExc "Second one went wrong:")---- Functions like 'readLn' use failIO. These exception are NOT traced.-f :: [Int] -> IO Int-f = observe "f" (\ys -> failIO "Oops from f")---- Functions like 'head' use error. These exceptions are traced.-h :: [Int] -> Int-h = observe "h" (\ys -> error "Oops from h!")--xs :: [Int]-xs = observe "xs" ({-# SCC "xs" #-} [])--handleExc :: String -> SomeException -> IO ()-handleExc s e = putStrLn (s ++ show e)
− examples/IndirectRecursion.lhs 
@@ -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--> $(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 = runO $ print (f 1)
+ examples/Insertion_Sort_elements_disappear.hs view
@@ -0,0 +1,23 @@+-- 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"
− examples/Insort.lhs 
@@ -1,28 +0,0 @@-Haskell version of the buggy insertion sort as shown in Lee Naish-A Declarative Debugging Scheme.--> {-# LANGUAGE TemplateHaskell, Rank2Types #-}-> import Debug.Hoed-> $(observedTypes "isort"  [[t|forall a . Observable a => [] a|]])-> $(observedTypes "insert" [[t|forall a . Observable a => [] a|]])-> $(observedTypes "result" [[t|forall a . Observable a => [] a|]])--Insertion sort.--> isort :: [Int] -> [Int]-> isort ns = $(observeTempl "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 = ($(observeTempl "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 = printO $->          $(observeTempl "result") ({-# SCC "result" #-} isort [1,2])
− examples/Insort2.hs 
@@ -1,27 +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---- 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 = printO $-         (observe "result") ({-# SCC "result" #-} isort [1,2])
+ examples/Parity.hs view
@@ -0,0 +1,19 @@+-- 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
− examples/Pretty.hs 
@@ -1,424 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveGeneric #-}--import Data.List(sort,sortBy,partition)-import Data.Array as Array-import Debug.Hoed(observe,Observable(..),runO,Generic)----------------------------------------------------------------------------- Make our datatypes observable--instance Observable CDS-instance Observable DOC-instance Observable CompStmt-instance Observable Output----------------------------------------------------------------------------- The main program with the failing testcase.--main = runO $ print (renderCompStmts cdss)--cdss = [CDSNamed "f" [CDSFun 0 [CDSCons 0 "2" []] [CDSCons 0 "1" []] [],CDSFun 0 [CDSCons 0 "0" []] [CDSCons 0 "0" []] []],CDSNamed "g" [CDSFun 0 [CDSCons 0 "2" []] [CDSCons 0 "1" []] ["f"]]]----------------------------------------------------------------------------- Render equations from CDS set--renderCompStmts :: CDSSet -> [CompStmt]-renderCompStmts = observe "renderCompStmts" ({-# SCC "renderCompStmts" #-} map renderCompStmt)--renderCompStmt :: CDS -> CompStmt-renderCompStmt c' = observe "renderCompStmt" (\c-> {-# SCC "renderCompStmt" #-} renderCompStmt' c) c'-renderCompStmt' (CDSNamed name set) = CompStmt name equation (head stack)-  where equation    = pretty 80 (foldr (<>) nil doc) -- BUG: foldr (<>) just puts equations-                                                     -- beside eachother, rather than seperating-                                                     -- them with commas-        (doc,stack) = unzip rendered-        rendered    = map (renderNamedTop name) output-        output      = cdssToOutput set-        -- MF TODO: Do we want to sort?-        -- output      = (commonOutput . cdssToOutput) set-renderCompStmt' _ = CompStmt "??" "??" emptyStack--renderNamedTop :: String -> Output -> (DOC,CallStack)-renderNamedTop arg1 arg2 = observe "renderNamedTop" -                           (\arg1' arg2' -> {-# SCC "renderNamedTop" #-} renderNamedTop' arg1' arg2'-                           ) arg1 arg2-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--renderCallStack :: CallStack -> DOC-renderCallStack s-  =  text "With call stack: ["-  <> foldl1 (\a b -> a <> text ", " <> b) -            (map text s)-  <> text "]"----------------------------------------------------------------------------- The CompStmt type--data CompStmt = CompStmt {equLabel :: String, equRes :: String, equStack :: CallStack}-                deriving (Eq, Ord, Generic)--instance Show CompStmt where-  show e = equRes e -- ++ " with stack " ++ show (equStack e)-  showList eqs eq = unlines (map show eqs) ++ eq---- 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---- The CDS and converting functions--data CDS = CDSNamed String         CDSSet-         | CDSCons Int String     [CDSSet]-         | CDSFun  Int             CDSSet CDSSet CallStack-         | CDSEntered Int-         | CDSTerminated Int-        deriving (Show,Eq,Ord,Generic)--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) -> CDSNamed str (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 arg1 arg2 = observe "renderNamedFn" -                                (\arg1' arg2' -> {-# SCC "renderNamedFn" #-}-                                renderNamedFn' arg1' arg2') arg1 arg2-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-            )-         )----- This is where the call stacks are merged.------ 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') -> 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 set)   = CDSNamed str (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 set) = CDSNamed str (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,Generic)---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,Generic)-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 = observe "pretty" (\w' x'-> {-# SCC "pretty" #-} pretty' w' x') w x-pretty' w x             = layout (best w 0 x)----------------------------------------------------------------------------- Stacks--emptyStack = [""]-type CallStack = [String]----------------------------------------------------------------------------- Events-data Event = Event-                { portId     :: !Int-                , parent     :: !Parent-                , change     :: !Change-                }-        deriving (Show, Read)--data Change-        = Observe       !String-        | Cons    !Int  !String-        | Enter-        | NoEnter-        | Fun           !CallStack-        deriving (Show, Read)--data Parent = Parent-        { observeParent :: !Int -- my parent-        , observePort   :: !Int -- my branch number-        } deriving (Show, Read)-root = Parent 0 0
− examples/Responsibility.lhs 
@@ -1,32 +0,0 @@-> import Debug.Hoed--sacc "outer" 1 + (sacc "inner" 2 * x)--> ex1 :: Int -> Int-> ex1 = (observe "outer") (\x -> {-# SCC "outer" #-} ->          1 + (((observe "inner") (\x -> {-# SCC "inner" #-} 2 * x)) x)->       )--(sacc "com" \f g x -> f (g x)) (sacc "add" (+1)) (sacc "mul" (*2))--> ex2 :: Int -> Int-> ex2 = ((observe "com1") (\f g x -> {-# SCC "com1" #-} f (g x)))->       ((observe "add1") ({-# SCC "add1" #-} (+1)))->       ((observe "mul1") ({-# SCC "add1" #-} (*2)))--> ex3 :: Int -> Int-> ex3 = let f = ((observe "add2") ({-# SCC "add2" #-} (+1)))->           g = ((observe "mul2") ({-# SCC "add2" #-} (*2)))->       in  ((observe "com2") (\x -> {-# SCC "com2" #-} f (g x)))---> ex4 :: Int -> Int-> ex4 = let f = ((observe "f") ({-# SCC "f" #-} (+1)))->           g = ((observe "g") ({-# SCC "g" #-} (*2)))->       in  ((observe "h") ({-# SCC "h" #-} f . g))---> main = runO $ do print (ex1 4)->                  print (ex2 4)->                  print (ex3 4)->                  print (ex4 4)
+ examples/SimpleHO.hs view
@@ -0,0 +1,9 @@+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)
− examples/TightRope.hs 
@@ -1,30 +0,0 @@--- This is an example from the "Learn You A Haskell" tuturial.--- The story is that there is a guy walking with a Pole where birds--- can land on the left and right. If the difference between birds--- on the left and right gets too big he falls off the rope. This--- is indicated by Nothing.--import Debug.Hoed(runO,observe)--type Birds = Int-type Pole  = (Birds,Birds)--landLeft :: Birds -> Pole -> Maybe Pole-landLeft n p = observe "landLeft" (\n' p' -> {-# SCC "landLeft" #-} landLeft' n' p') n p-landLeft' n (left,right)-  | abs ((left + n) - right) < 4 = Just (left + n, right)-  | otherwise                    = Nothing--landRight :: Birds -> Pole -> Maybe Pole-landRight n p = observe "landRight" (\n' p' -> {-# SCC "landRight" #-} landRight' n' p') n p-landRight' n (left,right)-  | abs (left - (right + n)) < 4 = Just (left, right + n)-  | otherwise                    = Nothing-        where x + y = x Prelude.+ (abs y)--walk :: Maybe Pole-walk = observe "walk" $ {-# SCC "walk" #-}-        return (0,0) >>= landRight 1  >>= landLeft 1-          >>= landRight 2 >>= landRight (-1) >>= landRight 1--main = runO $ print walk
− examples/TightRope2.hs 
@@ -1,53 +0,0 @@--- This is an example from the "Learn You A Haskell" tuturial.--- The story is that there is a guy walking with a Pole where birds--- can land on the left and right. If the difference between birds--- on the left and right gets too big he falls off the rope. This--- is indicated by Nothing.--import Debug.Hoed(runO,observe,observe',Identifier(..))--type Birds = Int-type Pole  = (Birds,Birds)--landLeft :: Birds -> Identifier -> Pole -> (Maybe Pole, Int)-landLeft n d p = let (f,i) = observe' "landLeft" d -                                (\n' p' -> {-# SCC "landLeft" #-} landLeft' n' p')-                  in (f n p, i)-landLeft' n (left,right)-  | abs ((left + n) - right) < 4 = Just (left + n, right)-  | otherwise                    = Nothing--landRight :: Birds -> Identifier -> Pole -> (Maybe Pole, Int)-landRight n d p = let (f,i) = observe' "landRight" d -                                 (\n' p' -> {-# SCC "landRight" #-} landRight' n' p')-                   in (f n p, i)-landRight' n (left,right)-  | abs (left - (right + n)) < 4 = Just (left, right + n)-  | otherwise                    = Nothing-        where x + y = x Prelude.+ (abs y)--walk :: Maybe Pole-walk = observe "walk" $ {-# SCC "walk" #-}-        return (0,0) *>>= landRight 1   >>== landLeft 1-          >>== landRight 2 >>== landRight (-1) >>=* landRight 1--main = runO $ print walk------------------------------------------------------------------------------------- This used to be part of Observe, but implementing instance of TracedMonad--- for IO and State are challenging.--class (Monad m) => TracedMonad m where-  (*>>=) :: Monad m => m a               -> (Identifier -> a -> (m b, Int)) -> (m b, Identifier)-  (>>==) :: Monad m => (m a, Identifier) -> (Identifier -> a -> (m b, Int)) -> (m b, Identifier)-  (>>=*) :: Monad m => (m a, Identifier) -> (Identifier -> a -> (m b, Int)) -> m b--instance TracedMonad Maybe where-  (Just x)    *>>= f = let (y,i) = f UnknownId x in (y,InSequenceAfter i)-  Nothing     *>>= f = (Nothing, UnknownId)--  (Just x, d) >>== f = let (y,i) = f d x in (y,InSequenceAfter i)-  (Nothing,_) >>== _ = (Nothing, UnknownId)--  (Just x,d)  >>=* f = fst (f d x)-  (Nothing,_) >>=* f = Nothing
− examples/TightRope3.hs 
@@ -1,34 +0,0 @@--- This is an example from the "Learn You A Haskell" tuturial.--- The story is that there is a guy walking with a Pole where birds--- can land on the left and right. If the difference between birds--- on the left and right gets too big he falls off the rope. This--- is indicated by Nothing.--import Debug.Hoed(runO,observe,observe',Identifier(..),(*>>=),(>>==),(>>=*))--type Birds = Int-type Pole  = (Birds,Birds)--landLeft :: Birds -> Identifier -> (Pole -> Maybe Pole, Int)-landLeft n d-  = let (f,i) = observe' "landLeft" d (\n' p' -> {-# SCC "landLeft" #-} landLeft' n' p')-    in (f n, i)-landLeft' n (left,right)-  | abs ((left + n) - right) < 4 = Just (left + n, right)-  | otherwise                    = Nothing--landRight :: Birds -> Identifier -> (Pole -> Maybe Pole, Int)-landRight n d -  = let (f,i) = observe' "landRight" d (\n' p' -> {-# SCC "landRight" #-} landRight' n' p')-    in  (f n, i)-landRight' n (left,right)-  | abs (left - (right + n)) < 4 = Just (left, right + n)-  | otherwise                    = Nothing-        where x + y = x Prelude.+ (abs y)--walk :: Maybe Pole-walk = observe "walk" $ {-# SCC "walk" #-}-        return (0,0) *>>= landRight 1   >>== landLeft 1-          >>== landRight 2 >>== landRight (-1) >>=* landRight 1--main = runO $ print walk
+ examples/XMonad_changing_focus_duplicates_windows/Main.hs view
@@ -0,0 +1,43 @@+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)+      ]
+ examples/XMonad_changing_focus_duplicates_windows__CC/Main.hs view
@@ -0,0 +1,43 @@+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)+  --     ]
+ examples/XMonad_changing_focus_duplicates_windows__using_properties/Main.hs view
@@ -0,0 +1,225 @@+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 = runOwp propositions $ do+  g <- newStdGen+  print . fromJust . ok . (generate 1 g) . evaluate $  prop_shift_win_I 1 'd' myStackSet+  where+    propositions =+        [Propositions [(QuickCheckProposition,module_Properties,"prop_focus_all_l",[0])+                      ,(QuickCheckProposition,module_Properties,"prop_focus_all_l_weak",[0])+                      ]+                      PropertiesOf "focusUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe]++        , Propositions [ (QuickCheckProposition,module_Properties,"prop_insert_duplicate_weak",[1,0])+                       ] +                       PropertiesOf "insertUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe]++        , Propositions [ (QuickCheckProposition,module_Properties,"prop_view_reversible",[1,0])+                       , (QuickCheckProposition,module_Properties,"prop_view_I",[1,0])+                       , (QuickCheckProposition,module_Properties,"prop_view_current",[0,1])+                       , (QuickCheckProposition,module_Properties,"prop_view_idem",[0,1])+                       , (QuickCheckProposition,module_Properties,"prop_view_local",[0,1])+                       ] +                       PropertiesOf "view" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe]++        , Propositions [ (QuickCheckProposition,module_Properties,"prop_greedyView_reversible",[1,0])+                       , (QuickCheckProposition,module_Properties,"prop_greedyView_idem",[0,1])+                       ] +                       PropertiesOf "greedyView" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe]++        ]++    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)+        -- ,("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)++        ]+-}++
+ examples/afp02Exercises/Compiler/Main.hs view
@@ -0,0 +1,18 @@+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"
+ img/faulty.png view

binary file changed (absent → 20469 bytes)

+ img/hoed-logo.png view

binary file changed (absent → 229149 bytes)

+ img/right.png view

binary file changed (absent → 3529 bytes)

+ img/unassessed.png view

binary file changed (absent → 6764 bytes)

+ img/wrong.png view

binary file changed (absent → 1866 bytes)

+ run view
@@ -0,0 +1,47 @@+#!/bin/bash+EXAMPLES=`ls dist/build | grep hoed-examples`+ulimit -v 1000000 # limit memory usage to 10 GB++echo "Available examples:"+i=0+for e in $EXAMPLES; do+  echo -n "$i) "+  echo $e | sed 's/^hoed-examples-//' | sed 's/__.*/ (&)/' |sed 's/__//' |  sed 's/_/ /g'+  ((i++))+done++echo -n "Select program or -1 to cancel: "+read++# Find the appropriate example from the given input+j=0+for e in $EXAMPLES; do+  if ((j==$REPLY)); then +    EXE=$e+    break+  fi+  ((j++))+done++# Or exit if the input was invalid (or -1)+if ((j>=i)); then+  echo "Bye"+  exit 1+fi++echo "Now executing $EXE."++rm -f tmp/wwwroot/debugTree.png tmp/debugTree.dot+cd tmp+# if echo $EXE | grep -q does_not_terminate; then+#   echo "You selected a non terminating program. Will kill after 1 second."+#   ../dist/build/$EXE/$EXE +RTS -p -h -L80 &+#   sleep 1s+#   kill -2 $! # send a "ctrl-C" signal to stop the hanging compiler...+#   wait+# else+# ../dist/build/$EXE/$EXE +RTS -p -h -L80+# fi+eval ../dist/build/$EXE/$EXE++
+ test.Generic view
@@ -0,0 +1,34 @@+#!/bin/bash++TESTS="0 1 2 3"+FAIL=0++echo "Testing events produced for Observable derived for Generic types"+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 n in $TESTS; do+  for x in r t; do+    t=${x}${n}+    eval ../../dist/build/hoed-tests-Generic-${t}/hoed-tests-Generic-${t} &> $t.out+    mv .Hoed/Events ${t}.Events+  done+  diff r${n}.Events t${n}.Events &> ${t}.diff+  if [ $? -eq 0 ]; then+    echo -n "[OK"+  else+    FAIL=1+    echo -n "["+    echo -en '\E[37;31m'"\033[1m!!\033[0m" # red "!!" on white background+    tput sgr0                              # reset colour+  fi+  echo "] Generic.t$n"+done++exit $FAIL
+ test.Pure view
@@ -0,0 +1,33 @@+#!/bin/bash+ulimit -v 1000000 # limit memory usage to 10 GB++TESTS=`ls dist/build | grep hoed-tests-Pure`+FAIL=0++echo "Testing Hoed-pure"+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+  mv .Hoed/Events ${t}.Events+  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
+ test.Stk view
@@ -0,0 +1,31 @@+#!/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
+ tests/Prop/t0/Main.hs view
@@ -0,0 +1,13 @@+-- A program with unexpected output.++import MyModule+import Debug.Hoed.Pure++-- main = quickcheck prop_idemSimplify+main = logOwp "hoed-tests-Prop-t0.graph" properties $ print $ prop_idemSimplify (Mul (Const 1) (Const 2))+  where+  properties = [ Propositions [(BoolProposition,myModule,"prop_idemOne",[0])]      PropertiesOf "one" []+               , Propositions [(BoolProposition,myModule,"prop_idemZero",[0])]     PropertiesOf "zero" []+               , Propositions [(BoolProposition,myModule,"prop_idemSimplify",[0])] PropertiesOf "simplify" []+               ]+  myModule = Module "MyModule" "../Prop/t0/"
+ tests/Prop/t1/Main.hs view
@@ -0,0 +1,11 @@+-- A program with unexpected output.+import CNF+import Debug.Hoed.Pure++-- main = quickcheck prop_idem_negin_sound+main = logOwp "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 [(BoolProposition,cnfModule,"prop_negin_complete",[0]), (BoolProposition,cnfModule,"prop_negin_sound",[0])] Specify "negin" []+               ]+  cnfModule  = Module "CNF" "../Prop/t1/"
+ tests/Prop/t2/Main.hs view
@@ -0,0 +1,12 @@+-- A program with unexpected output.+import Digraph+import Debug.Hoed.Pure++-- main = quickcheck prop_idem_negin_sound+main = logOwp "hoed-tests-Prop-t2.graph" properties $ print (prop_assoc1toNdigraph eg)+  where+  properties = [ Propositions [(BoolProposition,digraphModule,"prop_assoc1toNdigraph",[0])]    Specify "assoc1toNdigraph" []+               , Propositions [(BoolProposition,digraphModule,"prop_mergeAndSortTargets",[0])] Specify "mergeAndSortTargets" []+               , Propositions [(BoolProposition,digraphModule,"prop_addMissingSources",[0])]   Specify "addMissingSources" []+               ]+  digraphModule = Module "Digraph" "../Prop/t2/"
+ tests/Prop/t3/Main.hs view
@@ -0,0 +1,226 @@+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 "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 [(QuickCheckProposition,module_Properties,"prop_focus_all_l",[0])+                      ,(QuickCheckProposition,module_Properties,"prop_focus_all_l_generic",[0])+                      -- ,(QuickCheckProposition,module_Properties,"prop_focus_all_l_weak",[0])+                      ]+                      PropertiesOf "focusUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe]++        , Propositions [ (QuickCheckProposition,module_Properties,"prop_view_reversible",[1,0])+                       , (QuickCheckProposition,module_Properties,"prop_view_I",[1,0])+                       , (QuickCheckProposition,module_Properties,"prop_view_current",[0,1])+                       , (QuickCheckProposition,module_Properties,"prop_view_idem",[0,1])+                       , (QuickCheckProposition,module_Properties,"prop_view_local",[0,1])+                       ] +                       PropertiesOf "view" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe]+        , Propositions [ (QuickCheckProposition,module_Properties,"prop_greedyView_reversible",[1,0])+                       , (QuickCheckProposition,module_Properties,"prop_greedyView_idem",[0,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)++        ]+-}++
+ tests/Prop/t4/Main.hs view
@@ -0,0 +1,225 @@+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 "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 [(QuickCheckProposition,module_Properties,"prop_focus_all_l",[0])+                      -- ,(QuickCheckProposition,module_Properties,"prop_focus_all_l_weak",[0])+                      ]+                      PropertiesOf "focusUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe]++        -- , Propositions [ (QuickCheckProposition,module_Properties,"prop_insert_duplicate_weak",[1,0])+        --                ] +        --                PropertiesOf "insertUp" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe]++        , Propositions [ (QuickCheckProposition,module_Properties,"prop_view_reversible",[1,0])+                       , (QuickCheckProposition,module_Properties,"prop_view_I",[1,0])+                       , (QuickCheckProposition,module_Properties,"prop_view_current",[0,1])+                       , (QuickCheckProposition,module_Properties,"prop_view_idem",[0,1])+                       , (QuickCheckProposition,module_Properties,"prop_view_local",[0,1])+                       ] +                       PropertiesOf "view" [module_StackSet, module_QuickCheck, module_Map, module_Random, module_Maybe]++        , Propositions [ (QuickCheckProposition,module_Properties,"prop_greedyView_reversible",[1,0])+                       , (QuickCheckProposition,module_Properties,"prop_greedyView_idem",[0,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)++        ]+-}++
+ tests/Pure/t5.hs view
@@ -0,0 +1,13 @@+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)
+ tests/Pure/t6.hs view
@@ -0,0 +1,20 @@+{-# 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
+ tests/Pure/t7.hs view
@@ -0,0 +1,18 @@+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)