Hoed 0.4.1 → 0.5.0

raw patch · 30 files changed

+1272/−416 lines, 30 filesdep +cereal-textdep +cereal-vectordep +hashablePVP ok

version bump matches the API change (PVP)

Dependencies added: cereal-text, cereal-vector, hashable, hashtables, open-browser, primitive, regex-tdfa-text, text, transformers, vector-th-unbox

API changes (from Hackage documentation)

Files

• Data/Rope/Mutable.hs +95/−0
• Debug/Hoed.hs +62/−39
• Debug/Hoed/CompTree.hs +71/−43
• Debug/Hoed/Console.hs +356/−19
• Debug/Hoed/EventForest.hs +27/−25
• Debug/Hoed/Observe.lhs +198/−120
• Debug/Hoed/Prop.hs +31/−32
• Debug/Hoed/Render.hs +177/−91
• Debug/Hoed/Serialize.hs +9/−0
• Debug/Hoed/TH.hs +5/−3
• Debug/Hoed/Util.hs +35/−0
• Hoed.cabal +21/−2
• Text/PrettyPrint/FPretty.hs +6/−1
• changelog +12/−0
• examples/Queens__with_properties/Queens.hs +2/−0
• tests/Pure/t1.hs +1/−0
• tests/Pure/t2.hs +1/−0
• tests/Pure/t3.hs +1/−0
• tests/Pure/t4.hs +1/−0
• tests/Pure/t5.hs +1/−0
• tests/Pure/t6.hs +1/−0
• tests/Pure/t7.hs +1/−0
• tests/TH/quicksort.hs +26/−0
• tests/ref/hoed-tests-Pure-t1.graph +4/−4
• tests/ref/hoed-tests-Pure-t2.graph +12/−12
• tests/ref/hoed-tests-Pure-t3.graph +9/−9
• tests/ref/hoed-tests-Pure-t4.graph +8/−8
• tests/ref/hoed-tests-Pure-t5.graph +4/−4
• tests/ref/hoed-tests-Pure-t7.graph +4/−4
• tests/ref/hoed-tests-th-quicksort.graph +91/−0

@@ -0,0 +1,95 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+module Data.Rope.Mutable+  ( Rope+  , Data.Rope.Mutable.new+  , new'+  , fromList+  , write+  , reset+  ) where++import Control.Monad+import Control.Monad.Primitive+import Data.Foldable as F+import Data.Primitive.MutVar+import Data.Proxy+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as M+import Data.Vector.Generic.Mutable as M (MVector, read, new)++data RopeState m v a = RopeState+  { ropeDepth :: !Int+  , ropeLastIndex :: !Int+  , ropeElements :: [v (PrimState m) a]+  , spillOver :: v (PrimState m) a+  }++-- | A mutable bag-like collection with atomic O(1) inserts+data Rope m v a = Rope+  { ropeState   :: MutVar (PrimState m) (RopeState m v a)+  , ropeDim     :: !Int -- ^ Size of internal vectors+  }++defaultRopeDim = 10000++{-# INLINE write #-}+write :: forall v a m . (PrimMonad m, MVector v a) => Rope m v a -> Int -> a -> m ()+write Rope {..} (fromEnum -> ix) a = join $ atomicModifyMutVar' ropeState updateState+  where+    (d, r) = divMod ix ropeDim+    updateState :: RopeState m v a -> (RopeState m v a, m ())+    updateState st@RopeState {..}+      | d < ropeDepth =+        ( st {ropeLastIndex = max ropeLastIndex ix}+        , M.unsafeWrite (ropeElements !! (ropeDepth - 1 - d)) r a)+      | d == ropeDepth =+        ( st+          { ropeElements = spillOver : ropeElements+          , ropeDepth = d + 1+          , ropeLastIndex = max ropeLastIndex ix+          }+        , do M.unsafeWrite spillOver r a+             v <- M.new ropeDim+             atomicModifyMutVar' ropeState $ \st' -> (st' {spillOver = v}, ()))+      | otherwise = error $ "index " ++ show ix ++ " too far away from the last index " ++ show ropeLastIndex++new :: forall v a m . (PrimMonad m, MVector v a) => m (Rope m v a)+new = new' defaultRopeDim++new' :: forall v a m . (PrimMonad m, MVector v a) => Int -> m (Rope m v a)+new' ropeDim = do+  spillOver  <- M.new ropeDim+  ropeState <- newMutVar (RopeState 0 (-1) [] spillOver)+  return Rope{..}++-- | Returns an immutable snapshot of the rope contents after resetting the rope to the empty state+reset :: forall v a m . (VG.Vector v a, PrimMonad m) => Proxy v -> Rope m (VG.Mutable v) a -> m (v a)+reset proxy it@Rope{..} = do+  (lastIndex, ropeElements) <-+    atomicModifyMutVar' ropeState $ \RopeState {..} ->+      (RopeState 0 (-1) [] spillOver, (ropeLastIndex, ropeElements))+  lv <- mapM VG.unsafeFreeze ropeElements+  let joined :: v a+        | h:t <- lv+        = VG.concat (reverse t ++ [VG.slice 0 (lastIndex `mod` ropeDim + 1) h])+        | otherwise = VG.empty+  return joined++fromList :: forall v m a. (PrimMonad m, MVector v a) => Int -> [a] -> m(Rope m v a)+fromList dim xx = do+  rope <- new' dim+  forM_ (zip [0..] xx) $ \(i,x) -> write rope i x+  return rope++propFromList dim xx =+  check . toList <$> (reset (Proxy :: Proxy V.Vector) =<< fromList dim xx)+  where+    check xx'+      | xx == xx' = True+      | otherwise = error (show xx')

@@ -1,6 +1,8 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImplicitParams  #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}@@ -184,7 +186,6 @@   , UnevalHandler(..)     -- * The Observable class-  , Observer(..)   , Observable(..)   , (<<)   , thunk@@ -198,13 +199,17 @@   ) where  import Control.DeepSeq+import Control.Monad+import qualified Data.Vector.Generic as VG import           Debug.Hoed.CompTree import           Debug.Hoed.Console import           Debug.Hoed.Observe import           Debug.Hoed.Prop import           Debug.Hoed.Render import           Debug.Hoed.Serialize+import           Debug.Hoed.Util +import           Data.Foldable (toList) import           Data.IORef import           Prelude                      hiding (Right) import           System.Clock@@ -245,11 +250,12 @@ debugO program =      do { runOnce         ; initUniq-        ; startEventStream         ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"         ; ourCatchAllIO (do { _ <- program ; return () })                         (hPutStrLn stderr . errorMsg)-        ; endEventStream+        ; res <- endEventStream+        ; initUniq+        ; return res         }  -- | The main entry point; run some IO code, and debug inside it.@@ -317,14 +323,8 @@   return ()  -data Verbosity = Verbose | Silent--condPutStrLn :: Verbosity -> String -> IO ()-condPutStrLn Silent _    = return ()-condPutStrLn Verbose msg = hPutStrLn stderr msg- data HoedAnalysis = HoedAnalysis-  { hoedTrace       :: [Event]+  { hoedTrace       :: Trace   , hoedCompTree    :: CompTree   } @@ -336,36 +336,62 @@ defaultHoedOptions :: HoedOptions defaultHoedOptions = HoedOptions Silent 110 +--------------------------------------------+ -- |Entry point giving you access to the internals of Hoed. Also see: runO. runO' :: HoedOptions -> IO a -> IO HoedAnalysis runO' HoedOptions{..} program = let ?statementWidth = prettyWidth in do+  hSetBuffering stderr NoBuffering   createDirectoryIfMissing True ".Hoed/"-  t1 <- getTime Monotonic+  tProgram <- stopWatch   condPutStrLn verbose "=== program output ===\n"   events <- debugO program-  t2 <- getTime Monotonic-  let programTime = toSecs(diffTimeSpec t1 t2)-  condPutStrLn verbose $ "\n=== program terminated (" ++ show programTime ++ " seconds) ==="-  condPutStrLn verbose"Please wait while the computation tree is constructed..."+  programTime <- tProgram+  condPutStrLn verbose $ "\n=== program terminated (" ++ show programTime ++ ") ===" -  let e = length events+#if defined(DEBUG)+  writeFile ".Hoed/Events"     (unlines . map show $ toList events)+#endif    condPutStrLn verbose "\n=== Statistics ===\n"-  condPutStrLn verbose $ show e ++ " events"+  condPutStrLn verbose $ show (VG.length events) ++ " events"+  condPutStrLn verbose"Please wait while the computation tree is constructed..." -  let !cdss = eventsToCDS events-      !eqs  = force $ renderCompStmts cdss-      ti   = traceInfo e (reverse events)-      !ds  = force $ dependencies ti-      ct  = mkCompTree eqs ds+  tTrace <- stopWatch+  ti  <- traceInfo verbose events+  traceTime <- tTrace+  condPutStrLn verbose $ " " ++ show traceTime +  let cdss = eventsToCDS events+      eqs  = renderCompStmts cdss+  let !ds  = force $ dependencies ti+      ct   = mkCompTree eqs ds++  condPutStr verbose "Calculating the nodes of the computation graph"+  tCds <- stopWatch+  forM_ (zip [0..] cdss) $ \(i,x) -> do+    evaluate (force x)+    when (isPowerOf 2 i) $ condPutStr verbose "."+  cdsTime <- tCds+  condPutStrLn verbose $ " " ++ show cdsTime++  condPutStr verbose "Rendering the nodes of the computation graph"+  tEqs <- stopWatch+  forM_ (zip [0..] eqs) $ \(i,x) -> do+    evaluate (case stmtDetails x of+                       StmtCon c _ -> seq c ()+                       StmtLam args res _ -> args `seq` res `seq` ())+    when (isPowerOf 2 i) $ condPutStr verbose "."+  eqsTime <- tEqs+  condPutStrLn verbose $ " " ++ show eqsTime+ #if defined(DEBUG)-  writeFile ".Hoed/Events"     (unlines . map show . reverse $ events)-  writeFile ".Hoed/Cdss"       (unlines . map show $ cdss2)-  writeFile ".Hoed/Eqs"        (unlines . map show $ eqs)+  -- writeFile ".Hoed/Cdss"       (unlines . map show $ cdss2)+  writeFile ".Hoed/Eqs"        (unlines . map show $ toList eqs)+  writeFile ".Hoed/Deps"       (unlines . map show $ toList ds) #endif #if defined(TRANSCRIPT)-  writeFile ".Hoed/Transcript" (getTranscript events ti)+  writeFile ".Hoed/Transcript" (getTranscript (toList events) ti) #endif    let n  = length eqs@@ -375,14 +401,15 @@   condPutStrLn verbose $ show (length . arcs $ ct) ++ " edges in computation tree"   condPutStrLn verbose $ "computation tree has a branch factor of " ++ show b ++ " (i.e the average number of children of non-leaf nodes)" -  t3 <- getTime Monotonic-  let compTime = toSecs(diffTimeSpec t2 t3)-  condPutStrLn verbose $ "\n=== Debug Session (" ++ show compTime ++ " seconds) ===\n"+  let compTime = traceTime + cdsTime + eqsTime+  condPutStrLn verbose $ "\n=== Debug Session (" ++ show compTime ++ ") ===\n"   return $ HoedAnalysis events ct-    where-       toSecs :: TimeSpec -> Double-       toSecs spec = fromIntegral(sec spec) + fromIntegral(nsec spec) * 1e-9 +isPowerOf n 0 = False+isPowerOf n k | n == k         = True+              | k `mod` n == 0 = isPowerOf n (k `div` n)+              | otherwise      = False+ -- | Trace and write computation tree to file. Useful for regression testing. logO :: FilePath -> IO a -> IO () logO filePath program = {- SCC "logO" -} do@@ -390,12 +417,6 @@   writeFile filePath (showGraph hoedCompTree)   return () -  where showGraph g        = showWith g showVertex showArc-        showVertex RootVertex = ("\".\"","shape=none")-        showVertex v       = ("\"" ++ (escape . showCompStmt) v ++ "\"", "")-        showArc _          = ""-        showCompStmt       = show . vertexStmt- -- | As logO, but with property-based judging. logOwp :: UnevalHandler -> FilePath -> [Propositions] -> IO a -> IO () logOwp handler filePath properties program = do@@ -413,7 +434,9 @@   #if __GLASGOW_HASKELL__ >= 710--- A catch-all instance for non observable types+-- NOTE: This instance is orphaned here deliberately.+--       Moving it will break polymorphic observations in GHC 8.2x+-- | A catch-all instance for non observable types that produces the opaque observation @<?>@. instance {-# OVERLAPPABLE #-} Observable a where   observer = observeOpaque "<?>"   constrain _ _ = error "constrained by untraced value"

@@ -3,10 +3,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiWayIf            #-}--- This file is part of the Haskell debugger Hoed.------ Copyright (c) Maarten Faddegon, 2015- {-# LANGUAGE BangPatterns          #-} {-# LANGUAGE CPP                   #-} {-# LANGUAGE DeriveGeneric         #-}@@ -15,6 +11,11 @@ {-# LANGUAGE OverloadedLists       #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +-- This file is part of the Haskell debugger Hoed.+--+-- Copyright (c) Maarten Faddegon, 2015++ module Debug.Hoed.CompTree ( CompTree , Vertex(..)@@ -41,25 +42,31 @@ , traceInfo , Graph(..) -- re-export from LibGraph )where-import           Control.Exception+import           Control.DeepSeq+import           Control.Exception as E import           Control.Monad-import           Control.Monad.ST import           Debug.Hoed.EventForest import           Debug.Hoed.Observe import           Debug.Hoed.Span import           Debug.Hoed.Render+import           Debug.Hoed.Util  import           Data.Bits+import qualified Data.Foldable          as F import           Data.Graph.Libgraph import qualified Data.Set               as Set+import           Data.Hashable import           Data.IntMap.Strict     (IntMap) import qualified Data.IntMap.Strict     as IntMap import           Data.IntSet            (IntSet) import           Data.List              (foldl', unfoldr) import           Data.Maybe import           Data.Semigroup-import           Data.Vector.Mutable as VM (STVector)+import           Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Mutable as VM+import           Data.Vector.Mutable as VM (IOVector) import qualified Data.Vector.Unboxed    as U import           Data.Word import           GHC.Exts               (IsList (..))@@ -67,8 +74,24 @@ import           Prelude                hiding (Right)  data Vertex = RootVertex | Vertex {vertexStmt :: CompStmt, vertexJmt :: Judgement}-  deriving (Eq,Show,Ord,Generic)+  deriving (Show,Ord,Generic) +instance Eq Vertex where+  RootVertex == RootVertex   = True+  v1@Vertex{} == v2@Vertex{} = vertexStmt v1 == vertexStmt v2+  _ == _ = False++instance Hashable Vertex where+  hashWithSalt s RootVertex    = s `hashWithSalt` (-1 :: Int)+  hashWithSalt s (Vertex cs _) = s `hashWithSalt` cs++instance NFData Vertex++-- FIXME These orphan instances should be moved to libgraph+instance NFData AssistedMessage+instance NFData Judgement+instance (NFData a, NFData b) => NFData (Arc a b)+ getJudgement :: Vertex -> Judgement getJudgement RootVertex = Right getJudgement v          = vertexJmt v@@ -108,7 +131,7 @@  vertexRes :: Vertex -> String vertexRes RootVertex = "RootVertex"-vertexRes v          = stmtRes . vertexStmt $ v+vertexRes v          = unpack . stmtRes . vertexStmt $ v  -- | The forest of computation trees. Also see the Libgraph library. type CompTree = Graph Vertex ()@@ -126,7 +149,7 @@ -- of the unjudged computation statements (i.e not Right or Wrong) in the tree. unjudgedCharacterCount :: CompTree -> Int unjudgedCharacterCount = sum . map characterCount . filter unjudged . vertices-  where characterCount = length . stmtLabel . vertexStmt+  where characterCount = fromIntegral . T.length . stmtLabel . vertexStmt  unjudged :: Vertex -> Bool unjudged = not . judged@@ -197,12 +220,12 @@ topLvlFun :: EventDetails -> UID topLvlFun EventDetails{topLvlFun_ = TopLvlFun x} = x -type EventDetailsStore s = VM.STVector s EventDetails+type EventDetailsStore s = VM.IOVector EventDetails -getEventDetails :: EventDetailsStore s -> UID -> ST s EventDetails+getEventDetails :: EventDetailsStore s -> UID -> IO EventDetails getEventDetails = VM.unsafeRead -setEventDetails :: EventDetailsStore s -> UID -> EventDetails -> ST s ()+setEventDetails :: EventDetailsStore s -> UID -> EventDetails -> IO () setEventDetails = VM.unsafeWrite  @@ -256,7 +279,7 @@ #endif ------------------------------------------------------------------------------------------------------------------------ -collectEventDetails :: EventDetailsStore s -> Event -> ST s (Bool,UID)+collectEventDetails :: EventDetailsStore s -> Event -> IO (Bool,UID) collectEventDetails v e = do             let !p = eventParent e             parentDetails <- getEventDetails v (parentUID p)@@ -267,12 +290,12 @@ -- When we see a Fun event whose parent is not a Fun event it is a top level Fun event, -- otherwise just copy the reference to the top level Fun event from the parent. -- A top level Fun event references itself.-mkFunDetails :: EventDetailsStore s -> Event -> ST s EventDetails-mkFunDetails s e = do+mkFunDetails :: EventDetailsStore s -> UID -> Event -> IO EventDetails+mkFunDetails s uid e = do     let p = eventParent e     ed  <- getEventDetails s (parentUID p)     let !loc = locations ed (parentPosition p)-        !top = getTopLvlFunOr (eventUID e) ed+        !top = getTopLvlFunOr uid ed         locFun 0 = not loc         locFun 1 = loc     return $ EventDetails (TopLvlFun top) locFun@@ -331,69 +354,74 @@  --- Iff an event is a constant then the UID of its parent and its ParentPosition --- are elements of the ConsMap.-mkConsMap :: Int -> Trace -> ConsMap-mkConsMap l t =+mkConsMap :: Trace -> ConsMap+mkConsMap t =   U.create $ do-    v <- VM.replicate l 0-    forM_ t $ \e ->-      case change e of-        Cons {} -> do+    v <- VM.replicate (VG.length t) 0+    VG.forM_ t $ \e ->+      when (isCons (change e)) $ do           let p = eventParent e #if __GLASGOW_HASKELL__ >= 800-          VM.unsafeModify v (`setBit` parentPosition p) (parentUID p - 1)+          VM.unsafeModify v (`setBit` fromIntegral(parentPosition p)) (parentUID p) #else-          let ix = parentUID p - 1+          let ix = parentUID p           x <- VM.unsafeRead v ix-          VM.unsafeWrite v ix (x `setBit` parentPosition p)+          VM.unsafeWrite v ix (x `setBit` fromIntegral(parentPosition p)) #endif-        _ -> return ()     return v+  where+    isCons Cons{} = True+    isCons ConsChar{} = True+    isCons _ = False  corToCons :: ConsMap -> Event -> Bool-corToCons cm e = case U.unsafeIndex cm (parentUID p - 1) of+corToCons cm e = case U.unsafeIndex cm (parentUID p) of                    0 -> False-                   other -> testBit other (parentPosition p)+                   other -> testBit other (fromIntegral $ parentPosition p)   where p = eventParent e  ------------------------------------------------------------------------------------------------------------------------ -traceInfo :: Int -> Trace -> TraceInfo-traceInfo l trc = runST $ do-  -- Practically speaking, event UIDs start in 1-  v <- VM.replicate (l+1) $ EventDetails noTopLvlFun (const False)-  let loop !s e =-        case change e of+traceInfo :: Verbosity -> Trace -> IO TraceInfo+traceInfo verbose trc = do+  condPutStr verbose "Calculating the edges of the computation graph"+  v <- VM.replicate l $ EventDetails noTopLvlFun (const False)+  let loop !s uid e = do+        when (uid `mod` l100 == 0) $ condPutStr verbose "."+        case (change e) of           Observe {} -> do-            setEventDetails v (eventUID e) (EventDetails noTopLvlFun (const True))+            setEventDetails v uid (EventDetails noTopLvlFun (const True))             return s           Fun {} -> do-            setEventDetails v (eventUID e) =<< mkFunDetails v e+            setEventDetails v uid =<< mkFunDetails v uid e             return s             -- Span start           Enter {}             | corToCons cs e -> do               (loc, top) <- collectEventDetails v e               let !details = EventDetails (TopLvlFun top) (const loc)-              setEventDetails v (eventUID e) details+              setEventDetails v uid details               return $ if loc                   then addDependency e . start e details $ s                   else pause e details s             | otherwise -> return s-            -- Span end-          Cons {} -> do+            -- Span end (Cons or Char)+          other -> do             (loc, top) <- collectEventDetails v e             let !details = EventDetails (TopLvlFun top) (const loc)-            setEventDetails v (eventUID e) details+            setEventDetails v uid details             return $ if loc               then stop e details s               else resume e details s-  foldM loop s0 trc+  VG.ifoldM' loop s0 trc   where+    l = VG.length trc+    l100 = max 1 (l `div` 100)     s0 :: TraceInfo     s0 = TraceInfo [] [] #if defined(TRANSCRIPT)            IntMap.empty #endif     cs :: ConsMap-    cs = mkConsMap l trc+    cs = mkConsMap trc 

@@ -1,32 +1,319 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE LambdaCase                #-}-{-# LANGUAGE NamedFieldPuns            #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedLists       #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ViewPatterns          #-} -- This file is part of the Haskell debugger Hoed. -- -- Copyright (c) Maarten Faddegon, 2014-2017-module Debug.Hoed.Console(debugSession) where+module Debug.Hoed.Console(debugSession, showGraph) where  import           Control.Monad+import           Control.Arrow (first, second)+import           Data.Char+import           Data.Foldable            as F import           Data.Graph.Libgraph      as G-import           Data.List                as List (group, nub, sort)+import           Data.List                as List (foldl', group, mapAccumL, nub, sort) import qualified Data.Map.Strict          as Map+import qualified Data.IntMap.Strict       as IntMap import           Data.Maybe+import           Data.Sequence            (Seq, ViewL (..), viewl, (<|))+import qualified Data.Sequence            as Seq import qualified Data.Set                 as Set+import           Data.Text (Text, unpack)+import qualified Data.Text                as T+import qualified Data.Text.IO             as T+import qualified Data.Vector              as V+import qualified Data.Vector.Generic      as VG+import           Data.Word import           Debug.Hoed.Compat import           Debug.Hoed.CompTree import           Debug.Hoed.Observe import           Debug.Hoed.Prop import           Debug.Hoed.ReadLine import           Debug.Hoed.Render-import           Text.PrettyPrint.FPretty-import           Text.Regex.TDFA+import           Debug.Hoed.Serialize import           Prelude                  hiding (Right)+import           System.Directory+import           System.Exit+import           System.IO+import           System.Process+import           Text.PrettyPrint.FPretty hiding ((<$>))+import           Text.Regex.TDFA+import           Text.Regex.TDFA.Text+import           Web.Browser  {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} +--------------------------------------------------------------------------------+-- events+type Id = Int+-- | A representation of an event as a span+data Span = Span { spanStart, spanEnd :: Id, polarity :: Bool } deriving (Eq, Ord, Show)+-- | A representation of a trace as a span diagram: a list of columns of spans.+type Spans = [ [Span] ]+-- | The nesting depth of a span+type Depth = Int++-- | Recover the spans from the trace and arrange the columns such that they reflect+--   span containment. A span @b@ is contained in another span @a@ if+--+--   > start b > start a && end b < end a+--+--   The span in column N is contained below N other spans.+--   The renderer should draw the columns left to right.+traceToSpans :: (UID -> EventWithId) -> Trace -> Spans+traceToSpans lookupEvent =+  map sort .+  Map.elems .+  Map.fromListWith (++) .+  map (second (: [])) . snd . VG.ifoldl' (traceToSpans2' lookupEvent) ([], [])++-- This version tries to distinguish between Fun events that terminate a span,+-- and Fun events that signal a second application of a function+traceToSpans2'+  :: (UID -> EventWithId)+  -> (Seq Id, [(Depth, Span)])+  -> UID+  -> Event+  -> (Seq Id, [(Depth, Span)])+traceToSpans2' lookupEv (stack, result) uid e+  | isStart (change e) = (uid <| stack, result)+  | start :< stack' <- viewl stack+  , isEnd lookupEv uid e =+    ( stack'+    , (Seq.length stack', Span start uid (getPolarity e)) : result)+  | otherwise = (stack, result)+  where+    isStart Enter {} = True+    isStart _ = False+    getPolarity Event {change = Observe {}} = True+    getPolarity Event {eventParent = Parent p 0}+      | Event {change = Fun} <- event $ lookupEv p =+        not $ getPolarity (event $ lookupEv p)+    getPolarity Event {eventParent = Parent p _} = getPolarity (event $ lookupEv p)++isEnd lookupEv _ Event {change = Cons {}} = True+isEnd lookupEv uid me@(Event {change = Fun {}}) =+  case prevEv of+    Event{change = Enter{}} -> eventParent prevEv == eventParent me+    _ -> False+  where+    prevEv= event $ lookupEv (uid - 1)+isEnd _ _ _ = False++printTrace :: Trace -> IO ()+printTrace trace =+  putStrLn $+  renderTrace' lookupEvent lookupDescs (traceToSpans lookupEvent trace, trace)+    -- fast lookup via an array+  where+    lookupEvent i = EventWithId i (trace VG.! i)+    lookupDescs =+      (fromMaybe [] .+       (`IntMap.lookup` (IntMap.fromListWith+                           (++)+                           [ (p, [EventWithId uid e])+                           | (uid, e@Event {eventParent = Parent p _}) <-+                               VG.toList (VG.indexed trace)+                           ])))++-- | TODO to be improved+renderTrace :: (Spans, Trace) -> IO ()+renderTrace (spans, trace) = do+  putStrLn "Events"+  putStrLn "------"+  VG.mapM_ print trace+  putStrLn ""+  putStrLn "Spans"+  putStrLn "-----"+  mapM_ print spans++renderTrace' :: (UID -> EventWithId)+             -> (UID -> [EventWithId])+             -> (Spans, Trace)+             -> String+renderTrace' lookupEvent lookupDescs (columns, events) = unlines renderedLines+    -- roll :: State -> (Event, Maybe ColumnEvent) -> (State, String)+  where+    depth = length columns+    ((_, evWidth), renderedLines) =+      mapAccumL roll (replicate (depth + 1) ' ', 0)+      $ align (uncurry EventWithId <$> VG.toList (VG.indexed events)) columnEvents+    -- Merge trace events and column events+    align (ev:evs) (colEv@(rowIx, colIx, pol, isStart):colEvs)+      | eventUID ev == rowIx = (ev, Just (colIx, pol, isStart)) : align evs colEvs+      | otherwise = (ev, Nothing) : align evs (colEv : colEvs)+    align [] [] = []+    align ev [] = map  (\x -> (x, Nothing)) ev+    -- Produce the output in three columns: spans, events, and explains+    -- For spans: keep a state of the open spans+    --   (the state is the rendering in characters)+    -- For events: keep a state of the widest event+    -- For explains: circularly reuse the widest event result+    roll (state, width) (ev, Nothing)+      | (w, s) <- showWithExplains ev = ((state, max width w), state ++ s)+    roll (state, width) (ev, Just (col, pol, True))+      | state' <- update state col '|'+      , state'' <- update state col (if pol then '↑' else '┬')+      , (w, s) <- showWithExplains ev = ((state', max width w), state'' ++ s)+    roll (state, width) (ev, Just (col, pol, False))+      | state' <- update state col ' '+      , state'' <- update state col (if pol then '↓' else '┴')+      , (w, s) <- showWithExplains ev = ((state', max width w), state'' ++ s)+    -- columnEvents :: [(Line,ColIndex,StartOrEnd)]+    -- view the column spans as an event stream+    -- there's an event when a span starts or ends+    columnEvents =+      sortOn+        (\(a, b, c, d) -> a)+        [ (rowIx, colIx, pol, isStart)+        | (colIx, spans) <- zip [0 ..] columns+        , Span {..} <- spans+        , (rowIx, pol, isStart) <- [(spanStart, polarity, True), (spanEnd, polarity, False)]+        ]+    -- update element n of a list with a new value v+    update [] _ _ = []+    update (_:xs) 0 v = v : xs+    update (x:xs) n v = x : update xs (n - 1) v+    -- show the event, add the necessary padding to fill the event col width,+    -- and append the explain.+    showWithExplains ev+      | showEv <- show ev+      , l <- length showEv =+        (l, showEv ++ replicate (evWidth - l) ' ' ++ explain (eventUID ev) (event ev))+    -- Value requests+    explain uid Event {eventParent = Parent p 0, change = Enter}+      | Event {change = Fun, eventParent = Parent p' _} <- event $ lookupEvent p+      , (name,dist) <- findRoot (event $ lookupEvent p') =+        "-- request arg of " ++ unpack name ++ "/" ++ show (dist + 1)+    explain uid Event {eventParent = Parent p 1, change = Enter}+      | Event {change = Fun, eventParent = Parent p' _} <- event $ lookupEvent p+      , (name,dist) <- findRoot (event $ lookupEvent p') =+        "-- request result of " ++ unpack name ++ "/" ++ show (dist+1)+    explain uid Event {eventParent = Parent p 0, change = Enter}+      | Event {change = Observe name} <- event $ lookupEvent p =+        "-- request value of " ++ unpack name+    explain uid Event {eventParent = Parent p i, change = Enter}+      | Event {change = Cons ar name} <- event $ lookupEvent p =+        "-- request value of arg " ++ show i ++ " of constructor " ++ unpack name+    -- Arguments of functions+    explain uid me@Event {eventParent = Parent p 0, change = it@FunOrCons}+      | Event {change = Fun, eventParent = Parent p' _} <- event $ lookupEvent p+      , (name,dist) <- findRoot (event $ lookupEvent p') =+        "-- arg " ++ show (dist+1) ++ " of " ++ unpack name ++ " is " ++ showChange it+    -- Results of functions+    explain uid Event {eventParent = Parent p 1, change = it@Fun}+      | Event {change = Fun, eventParent = Parent p' _} <- event $ lookupEvent p+      , (name,dist) <- findRoot (event $ lookupEvent p') =+        "-- result of " ++ unpack name ++ "/" ++ show (dist+1) ++ " is a function"+    explain uid me@Event {eventParent = Parent p 1, change = Cons{}}+      | Event {change = Fun, eventParent = Parent p' _} <- event $ lookupEvent p+      , (name,dist) <- findRoot (event $ lookupEvent p')+      , arg <- findArg p =+        "-- " ++ unpack name ++ "/" ++ show (dist+1) ++ " " ++ arg ++" = " ++ findValue lookupDescs (EventWithId uid me)+    -- Descendants of Cons events+    explain uid Event {eventParent = Parent p i, change = Cons _ name}+      | Event {change = Cons ar name'} <- event $ lookupEvent p =+        "-- arg " ++ show i ++ " of constructor " ++ unpack name' ++ " is " ++ unpack name+    -- Descendants of root events+    explain uid Event {eventParent = Parent p i, change = Fun}+      | Event {change = Observe name} <- event $ lookupEvent p =+        "-- " ++ unpack name ++ " is a function"+    explain uid me@Event {eventParent = Parent p i, change = Cons{}}+      | Event {change = Observe name} <- event $ lookupEvent p =+        "-- " ++ unpack name ++ " = " ++ findValue lookupDescs (EventWithId uid me)+    explain _ _ = ""++    -- Returns the root observation for this event, together with the distance to it+    findRoot Event{change = Observe name} = (name, 0)+    findRoot Event{eventParent} = succ <$> findRoot (event $ lookupEvent $ parentUID eventParent)++    variableNames = map (:[]) ['a'..'z']++    showChange Fun = "a function"+    showChange (Cons ar name) = "constructor " ++ unpack name++    findArg eventUID =+      case [ e | e@(event -> Event{eventParent = Parent p 0, change = Cons{}}) <- lookupDescs eventUID] of+        [cons] -> findValue lookupDescs cons+        other  -> error $ "Unexpected set of descendants of " ++ show eventUID ++ ": Fun - " ++ show other++findValue :: (UID -> [EventWithId]) -> EventWithId -> String+findValue lookupDescs = go+  where+    go :: EventWithId -> String+    go EventWithId {eventUID = me, event = Event {change = ConsChar c}} = show c+    go EventWithId {eventUID = me, event = Event {change = Cons ar name}}+      | ar == 0 = unpack name+      | isAlpha (T.head name) =+        unpack name +++        " " +++        unwords+          (map go $+           sortOn+             (parentPosition . eventParent . event)+             [e | e@EventWithId {event = Event {change = Cons {}}} <- lookupDescs me])+      | ar == 1+      , [a] <- [e | e@EventWithId {event = Event {change = Cons {}}} <- lookupDescs me] = unpack name ++ go a+      | ar == 2+      , [a, b] <- sortOn (parentPosition . eventParent . event) [e | e@(event -> Event {change = Cons {}}) <- lookupDescs me] =+        unwords [go a, unpack name, go b]+    go EventWithId {eventUID, event = Event {change = Enter {}}}+      | [e] <- lookupDescs eventUID = go e+    go other = error $ show other++data RequestDetails = RD Int Explanation++data ReturnDetails+  = ReturnFun+  | ReturnCons { constructor :: Text, arity :: Word8, value :: String}++data Explanation+  = Observation String+  | Request RequestDetails+  | Return RequestDetails ReturnDetails++instance Show Explanation where+  show (Observation obs) = ""+  show (Request r) = "request " ++ showRequest r+  show (Return r val) = showReturn r val++showRequest (RD 0 (Observation name)) = unwords ["value of", name]+showRequest (RD 0 (Return (RD _ (Observation name)) ReturnFun)) = unwords ["arg of", name]+showRequest (RD 1 (Return (RD _ (Observation name)) ReturnFun)) = unwords ["result of", name]+showRequest (RD n (Return _ (ReturnCons name ar _))) = unwords ["arg", show n, "of constructor", unpack name ]++showReturn (RD p (Observation obs)) ReturnFun = unwords ["result of ", obs, "is a function"]+showReturn (RD p req) (ReturnCons name ar val) = unwords [show req, "=", val]++buildExplanation :: (UID -> EventWithId) -> (UID -> [EventWithId]) -> EventWithId -> Explanation+buildExplanation lookupEvent lookupDescs = go . event where+  go Event{eventParent = Parent p pos, change = Enter}+    | par <- go (event $ lookupEvent p)+    = Request (RD 0 par)+  go Event{eventParent = Parent p pos, change = Fun}+    | Request rd <- go (event $ lookupEvent p)+    = Return rd ReturnFun+  go Event{eventParent = Parent p pos, change = Cons ar name}+    | Request rd <- go (event $ lookupEvent p)+    , value <- findValue lookupDescs (lookupEvent p)+    = Return rd (ReturnCons name ar value)+++eitherFunOrCons Fun{} = True+eitherFunOrCons Cons {} = True+eitherFunOrCons _ = False++pattern FunOrCons <- (eitherFunOrCons -> True)++--------------------------------------------------------------------------------+-- Debug session+ debugSession :: Trace -> CompTree -> [Propositions] -> IO () debugSession trace tree ps =   case filter (not . isRootVertex) vs of@@ -118,7 +405,7 @@   , ps       :: [Propositions]   } -adbCommand, observeCommand, listCommand, exitCommand :: Command State+adbCommand, graphCommand, observeCommand, listCommand, exitCommand :: Command State adbCommand =   Command "adb" [] "Start algorithmic debugging." $ \case     [] -> Just $ \_ -> return $ Down adbFrame@@ -140,6 +427,17 @@       let regexp = makeRegex $ case args of [] -> ".*" ; _ -> unwords args       in Same <$ listStmts compTree regexp +graphCommand =+  Command "graph" ["regexp"]+    ("Show the computation graph of an expression." </>+     "Requires graphviz dotp.") $ \case+        regexp -> Just $ \State{..} -> Same <$ graphStmts (unwords regexp) compTree++eventsCommand =+  Command "events" [] "Print the Event trace (useful only for debugging Hoed)" $ \case+    [] -> Just $ \State{..} -> Same <$ printTrace trace+    _  -> Nothing+ exitCommand =   Command "exit" [] "Leave the debugging session." $ \case     [] -> Just $ \_ -> return (Up Nothing)@@ -149,6 +447,10 @@ mainLoopCommands =   sortOn name     [ adbCommand+#ifdef DEBUG+    , eventsCommand+#endif+    , graphCommand     , listCommand     , observeCommand     , exitCommand@@ -165,14 +467,14 @@  listStmts :: CompTree -> Regex -> IO () listStmts g regex =-  putStrLn $-  unlines $+  T.putStrLn $+  T.unlines $   snub $   map (stmtLabel . vertexStmt . G.root) $   selectVertices (\v -> matchLabel v && isRelevantToUser g v) g   where     matchLabel RootVertex = False-    matchLabel v          = match regex (stmtLabel $ vertexStmt v)+    matchLabel v          = match regex (unpack $ stmtLabel $ vertexStmt v)     snub = map head . List.group . sort  -- Restricted to statements for lambda functions or top level constants.@@ -207,6 +509,8 @@  -------------------------------------------------------------------------------- -- observe++ printStmts :: CompTree -> String -> IO () printStmts g regexp     | null vs_filtered  =@@ -228,7 +532,7 @@     show(vertexStmt $ G.root g) :     concat       [ "  where" :-        map ("    " ++) locals+        map (("    " ++) . unpack) locals       | not (null locals)]   where     locals =@@ -243,6 +547,43 @@               succs g (G.root g)           ] +--------------------------------------------------------------------------+-- graph+graphStmts :: String -> CompTree -> IO ()+graphStmts "" g = renderAndOpen g+graphStmts (makeRegex -> r) g = do+          let matches =+                map subGraphFromRoot $+                selectVertices (\v -> matchRegex r v && isRelevantToUser g v) g+          case matches of+            [one] -> renderAndOpen one+            _ ->+              putStrLn "More than one match, please select only one expression."++renderAndOpen g = do+  tempDir <- getTemporaryDirectory+  (tempFile, hTempFile) <- openTempFile tempDir "hoed.svg"+  hClose hTempFile+  cmd "dot" ["-Tsvg", "-o", tempFile] (showGraph g)+  _success <- openBrowser ("file:///" ++ tempFile)+  return ()++showGraph g = showWith g showVertex showArc+  where+    showVertex RootVertex = ("\".\"", "shape=none")+    showVertex v          = ("\"" ++ (escape . showCompStmt) v ++ "\"", "")+    showArc _ = ""+    showCompStmt = show . vertexStmt++cmd line args inp = do+  putStrLn $ unwords (line:args)+  (exit, stdout, stderr) <- readProcessWithExitCode line args inp+  unless (exit == ExitSuccess) $ do+    putStrLn $ "Failed with code: " ++ show exit+    putStrLn stdout+    putStrLn stderr+  return exit+ -------------------------------------------------------------------------------- -- algorithmic debugging @@ -330,8 +671,4 @@   unjudged' Right = False   unjudged' Wrong = False   unjudged' _     = True---- 

@@ -22,39 +22,40 @@ ) where import Debug.Hoed.Observe import Data.IntMap (IntMap)+import Data.Vector.Generic (ifoldl) import qualified Data.IntMap as IntMap  -- Searchable mapping from UID of the parent and position in list of siblings -- to a child event. -- type EventForest = [(UID, [(ParentPosition, Event)])]-type EventForest = IntMap [(ParentPosition, Event)]+type EventForest = IntMap [(ParentPosition, EventWithId)]  isRoot :: Event -> Bool isRoot e = case change e of Observe{} -> True; _ -> False -elems :: EventForest -> [[(ParentPosition, Event)]]+elems :: EventForest -> [[(ParentPosition, EventWithId)]] elems = IntMap.elems -addEvent :: EventForest -> Event -> EventForest-addEvent frt e-  | isRoot e  = frt+addEvent :: EventForest -> UID -> Event -> EventForest+addEvent frt uid e+  | isRoot e = frt   | otherwise = IntMap.insert i s frt   where i  = parentUID . eventParent $ e         p  = parentPosition . eventParent $ e         ms = IntMap.lookup i frt-        s  = case ms of Nothing   -> [(p,e)]-                        (Just s') -> (p,e) : s'+        s  = case ms of Nothing   -> [(p,EventWithId uid e)]+                        (Just s') ->  (p,EventWithId uid e) : s'   mkEventForest :: Trace -> EventForest-mkEventForest trc = foldl addEvent IntMap.empty trc+mkEventForest trc = ifoldl addEvent IntMap.empty trc -parentUIDLookup :: UID -> EventForest  -> [(ParentPosition,Event)]+parentUIDLookup :: UID -> EventForest  -> [(ParentPosition,EventWithId)] parentUIDLookup i frt = case IntMap.lookup i frt of   Nothing   -> []   (Just es) -> es -parentPosLookup :: ParentPosition -> [(ParentPosition,Event)] -> [Event]+parentPosLookup :: ParentPosition -> [(ParentPosition,EventWithId)] -> [EventWithId] parentPosLookup p = map snd . filter ((==p) . fst)  data InfixOrPrefix = Infix | Prefix@@ -62,13 +63,13 @@ data Location = Trunk | ArgumentOf Location | ResultOf Location | FieldOf Int Location   deriving Eq -instance Show Location where +instance Show Location where    show Trunk            = ""    show (ArgumentOf loc) = 'a' : show loc    show (ResultOf   loc) = 'r' : show loc    show (FieldOf n  loc) = 'f' : show n ++ show loc -type Visit a = Maybe Event -> Location -> a -> a+type Visit a = Maybe EventWithId -> Location -> a -> a  idVisit :: Visit a idVisit _ _ z = z@@ -82,30 +83,31 @@ -- particular ordering and we just return the applications (AppEvents) in the -- order we find them in the trace (i.e. evaluation order). -dfsChildren :: EventForest -> Event -> [Maybe Event]-dfsChildren frt e = case change e of+dfsChildren :: EventForest -> EventWithId -> [Maybe EventWithId]+dfsChildren frt e = case change (event e) of     Enter{}              -> manyByPosition 0 -- Should be Nothing?     (Cons l _)           -> foldl (\acc x -> acc ++ manyByPosition x) [] [0..(l-1)]+    ConsChar _           -> []     Observe{}            -> manyByPosition 0     Fun                  -> manyByPosition 0 ++ manyByPosition 1 -  where manyByPosition :: ParentPosition -> [Maybe Event]+  where manyByPosition :: ParentPosition -> [Maybe EventWithId]         manyByPosition pos = case filter (\(pos',_) -> pos == pos') cs of           [] -> [Nothing]           ts -> map (Just . snd) ts          -- Events in the frt that list our event as parent (in no particular order).-        cs :: [(ParentPosition,Event)]+        cs :: [(ParentPosition,EventWithId)]         cs = parentUIDLookup (eventUID e) frt           dfsFold :: InfixOrPrefix -> Visit a -> Visit a -> a -        -> Location -> (Maybe Event) -> EventForest -> a+        -> Location -> (Maybe EventWithId) -> EventForest -> a  dfsFold ip pre post z loc me frt    = post me loc $ case me of       Nothing -> z'-      (Just e) -> case change e of+      (Just e) -> case change (event e) of          Fun -> let [arg,res] = cs           in case ip of@@ -121,27 +123,27 @@    where z'  = pre me loc z -        cs :: [Maybe Event]+        cs :: [Maybe EventWithId]         cs = case me of (Just e) -> dfsChildren frt e; Nothing -> error "dfsFold filter failed"          csFold = foldl (\z'' (c,loc') -> dfsFold ip pre post z'' loc' c frt) z' -treeUIDs :: EventForest -> Event -> [UID]+treeUIDs :: EventForest -> EventWithId -> [UID] treeUIDs frt = (map eventUID) . eventsInTree frt  -- Given an event r, return depth first ordered list of events in the (sub)tree starting from r.-eventsInTree :: EventForest -> Event -> [Event]+eventsInTree :: EventForest -> EventWithId -> [EventWithId] eventsInTree frt r = reverse $ dfsFold Prefix add idVisit [] Trunk (Just r) frt   where add (Just e) _ es = e : es         add Nothing  _ es = es  -- Find all toplevel AppEvents for RootEvent r-topLevelApps :: EventForest -> Event -> [Event]+topLevelApps :: EventForest -> EventWithId -> [EventWithId] topLevelApps frt r = foldl appendApp []  $ dfsChildren frt r -appendApp :: [Event] -> Maybe Event -> [Event]+appendApp :: [EventWithId] -> Maybe EventWithId -> [EventWithId] appendApp z me = case me of   Nothing  -> z-  (Just e) -> case change e of Fun -> e : z-                               _   -> z+  (Just e) -> case change (event e) of Fun -> e : z+                                       _   -> z   

@@ -5,10 +5,16 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies  #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} @@ -90,9 +96,26 @@ \begin{code} import Prelude hiding (Right) import qualified Prelude+import Control.Concurrent.MVar import Control.Monad import Data.Array as Array+import qualified Data.HashTable.IO as H+import Data.IORef+import Data.List (sortOn)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Proxy+import Data.Rope.Mutable (Rope, new', write, reset)+import Data.Strict.Tuple (Pair(..))+import Data.Text (Text, pack)+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import Data.Vector.Unboxed (Vector)+import Data.Vector.Unboxed.Deriving+import Data.Vector.Unboxed.Mutable (MVector)+import Data.Word import Debug.Hoed.Fields+import Debug.Trace  import GHC.Generics @@ -114,13 +137,158 @@  \end{code} +%************************************************************************+%*                                                                      *+\subsection{Event stream}+%*                                                                      *+%************************************************************************++Trival output functions+ \begin{code}-infixl 9 <<++type UID = Int++data Event = Event { eventParent :: {-# UNPACK #-} !Parent+                   , change      ::                !Change  }+        deriving (Eq,Generic)++data EventWithId = EventWithId {eventUID :: !UID, event :: !Event}++data Change+        = Observe          !Text+        | Cons     !Word8  !Text+        | ConsChar         !Char+        | Enter+        | Fun+        deriving (Eq, Show,Generic)++type ParentPosition = Word8++data Parent = Parent+        { parentUID      :: !UID            -- my parents UID+        , parentPosition :: !ParentPosition -- my branch number (e.g. the field of a data constructor)+        } deriving (Eq,Generic)++instance Show Event where+  show e = (show . change $ e) ++ " (" ++ (show . eventParent $ e) ++ ")"++instance Show EventWithId where+  show (EventWithId uid e) = (show uid) ++ ": " ++ (show . change $ e) ++ " (" ++ (show . eventParent $ e) ++ ")"++instance Show Parent where+  show p = "P " ++ (show . parentUID $ p) ++ " " ++ (show . parentPosition $ p)++root = Parent (-1) 0++isRootEvent :: Event -> Bool+isRootEvent e = case change e of Observe{} -> True; _ -> False \end{code} +\begin{code}+type Trace = Vector Event++endEventStream :: IO Trace+endEventStream = do+  (stringsCount :!: stringsHashTable) <- takeMVar strings+  unsortedStrings <- H.toList stringsHashTable+  putMVar strings . (0 :!:) =<< H.new+  let stringsTable = V.unsafeAccum (\_ -> id) (V.replicate stringsCount (error "uninitialized")) [(i,s) | (s,i) <- unsortedStrings]+  writeIORef stringsLookupTable stringsTable+  reset (Proxy :: Proxy Vector) events++sendEvent :: Int -> Parent -> Change -> IO ()+sendEvent nodeId !parent !change = do+  write events nodeId (Event parent change)++lookupOrAddString s = do+  (stringsCount :!: stringsTable) <- takeMVar strings+  value <- H.lookup stringsTable s+  (count',res) <- case value of+            Just x -> return (stringsCount, x)+            Nothing -> H.insert stringsTable s stringsCount >> return (stringsCount+1, stringsCount)+  putMVar strings (count' :!: stringsTable)+  return res++-- Global store of unboxed events.+-- Since we cannot unbox Strings, these are represented as references to the+--  strings table+{-# NOINLINE events #-}+events :: Rope IO MVector Event+events = unsafePerformIO $ do+  rope <- new' 10000  -- size of the lazy vectors internal to the rope structure+  return rope++{-# NOINLINE strings #-}+strings :: MVar(Pair Int (H.CuckooHashTable Text Int))+strings = unsafePerformIO $ do+  h <- H.newSized 100000  -- suggested capacity for the hash table+  newMVar (0 :!: h)++{-# NOINLINE stringsLookupTable #-}+stringsLookupTable :: IORef (V.Vector Text)+stringsLookupTable = unsafePerformIO $ newIORef  mempty++lookupString id = unsafePerformIO $ (V.! id) <$> readIORef  stringsLookupTable++derivingUnbox "Change"+    [t| Change -> (Word8, Word8, Int) |]+    [| \case+            Observe  s -> (0,0,unsafePerformIO(lookupOrAddString s))+            Cons c   s -> (1,c,unsafePerformIO(lookupOrAddString s))+            ConsChar c -> (2,0,fromEnum c)+            Enter      -> (3,0,0)+            Fun        -> (4,0,0)+     |]+    [| \case (0,_,s) -> Observe (lookupString s)+             (1,c,s) -> Cons c  (lookupString s)+             (2,_,c) -> ConsChar (toEnum c)+             (3,_,_) -> Enter+             (4,_,_) -> Fun+     |]++derivingUnbox "Parent"+    [t| Parent -> (UID, ParentPosition) |]+    [| \ (Parent a b) -> (a,b) |]+    [| \ (a,b) -> Parent a b |]++derivingUnbox "Event"+    [t| Event -> (Parent, Change) |]+    [| \(Event a b) -> (a,b) |]+    [| \ (a,b) -> Event a b |]++\end{code}+  %************************************************************************ %*                                                                      *+\subsection{unique name supply code}+%*                                                                      *+%************************************************************************++Use the single threaded version++\begin{code}++initUniq :: IO ()+initUniq = writeIORef uniq 1++getUniq :: IO UID+getUniq = atomicModifyIORef' uniq (\n -> (n+1,n))++peepUniq :: IO UID+peepUniq = readIORef uniq++-- locals+{-# NOINLINE uniq #-}+uniq :: IORef UID+uniq = unsafePerformIO $ newIORef 0++\end{code}+++%************************************************************************+%*                                                                      * \subsection{GDM Generics} %*                                                                      * %************************************************************************@@ -128,8 +296,17 @@ The generic implementation of the observer function.  \begin{code}+-- | A type class for observable values.+--+--    * For 'Generic' datatypes it can be derived automatically.+--    * For opaque datatypes, use 'observeOpaque' or rely on the catch-all @<?>@ instance.+--    * Custom implementations can exclude one or more fields from the observation:+--+--    @ instance (Observable a, Observable b) => Observable (excluded, a,b) where+--        observe (excluded,a,b) = send "(,,)" (return (,,) excluded << a << b)+--    @ class Observable a where-        observer  :: a -> Parent -> a +        observer  :: a -> Parent -> a         default observer :: (Generic a, GObservable (Rep a)) => a -> Parent -> a         observer x c = to (gdmobserver (from x) c) @@ -140,7 +317,7 @@ class GObservable f where         gdmobserver :: f a -> Parent -> f a         gdmObserveArgs :: f a -> ObserverM (f a)-        gdmShallowShow :: f a -> String+        gdmShallowShow :: f a -> Text  constrainBase :: (Show a, Eq a) => a -> a -> a constrainBase x c | x == c = x@@ -190,7 +367,7 @@ instance (GObservable a, Constructor c) => GObservable (M1 C c a) where  gdmobserver m1 = send (gdmShallowShow m1) (gdmObserveArgs m1)  gdmObserveArgs (M1 x) = do {x' <- gdmObserveArgs x; return (M1 x')}- gdmShallowShow = conName+ gdmShallowShow = pack . conName  -- Unit: used for constructors without arguments instance GObservable U1 where@@ -254,7 +431,7 @@  The Haskell Base types  \begin{code}-instance Observable Int     where observer  = observeBase +instance Observable Int     where observer  = observeBase                                   constrain = constrainBase instance Observable Bool    where observer  = observeBase                                   constrain = constrainBase@@ -264,8 +441,11 @@                                   constrain = constrainBase instance Observable Double  where observer  = observeBase                                   constrain = constrainBase-instance Observable Char    where observer  = observeBase-                                  constrain = constrainBase+instance Observable Char    where+  observer lit cxt = seq lit $ unsafeWithUniq $ \node -> do+    sendEvent node cxt (ConsChar lit)+    return lit+  constrain = constrainBase instance Observable ()      where observer  = observeOpaque "()"                                   constrain = constrainBase @@ -275,9 +455,9 @@ -- we evalute to WHNF, and not further.  observeBase :: (Show a) => a -> Parent -> a-observeBase lit cxt = seq lit $ send (show lit) (return lit) cxt+observeBase lit cxt = seq lit $ send (pack $ show lit) (return lit) cxt -observeOpaque :: String -> a -> Parent -> a+observeOpaque :: Text -> a -> Parent -> a observeOpaque str val cxt = seq val $ send str (return val) cxt \end{code} @@ -337,7 +517,7 @@  \begin{code} instance Observable SomeException where-  observer e = send ("<Exception> " ++ show e) (return e)+  observer e = send ("<Exception> " <> pack(show e)) (return e)   constrain = undefined  -- instance Observable ErrorCall where@@ -356,13 +536,6 @@ %*                                                                      * %************************************************************************ -MF: why/when do we need these types?-\begin{code}-type Observing a = a -> a--newtype Observer = O (forall a . (Observable a) => String -> a -> a)-\end{code}-  %************************************************************************ %*                                                                      *@@ -374,7 +547,7 @@ for placing numbers on sub-observations.  \begin{code}-newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) }+newtype ObserverM a = ObserverM { runMO :: Int -> Word8 -> (a,Word8) }  instance Functor ObserverM where     fmap  = liftM@@ -411,6 +584,7 @@ (<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b -- fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') } fn << a = gdMapM (thunk observer) fn a+infixl 9 <<  gdMapM :: (Monad m)         => (a -> m a)  -- f@@ -444,7 +618,7 @@ -- 'observe' can also observe functions as well a structural values. --  {-# NOINLINE gobserve #-}-gobserve :: (a->Parent->a) -> String -> a -> (a,Int)+gobserve :: (a->Parent->a) -> Text -> a -> (a,Int) gobserve f name a = generateContext f name a  {- | @@ -477,7 +651,7 @@ @ -} {-# NOINLINE observe #-}-observe ::  (Observable a) => String -> a -> a+observe ::  (Observable a) => Text -> a -> a observe lbl = fst . (gobserve observer lbl)  {- This gets called before observer, allowing us to mark@@ -505,16 +679,16 @@ \end{code}  \begin{code}-generateContext :: (a->Parent->a) -> String -> a -> (a,Int)+generateContext :: (a->Parent->a) -> Text -> a -> (a,Int) generateContext f {- tti -} label orig = unsafeWithUniq $ \node ->-     do sendEvent node (Parent 0 0) (Observe label)+     do sendEvent node root (Observe label)         return (observer_ f orig (Parent                       { parentUID      = node                       , parentPosition = 0                       })                , node) -send :: String -> ObserverM a -> Parent -> a+send :: Text -> ObserverM a -> Parent -> a send consLabel fn context = unsafeWithUniq $ \ node ->      do { let (r,portCount) = runMO fn node 0         ; sendEvent node context (Cons portCount consLabel)@@ -548,106 +722,10 @@ \end{code}  -%************************************************************************-%*                                                                      *-\subsection{Event stream}-%*                                                                      *-%************************************************************************ -Trival output functions--\begin{code}-type Trace = [Event]--data Event = Event-                { eventUID     :: !UID      -- my UID-                , eventParent  :: !Parent-                , change       :: !Change-                }-        deriving (Eq,Generic)--data Change-        = Observe       !String-        | Cons    !Int  !String-        | Enter-        | Fun-        deriving (Eq, Show,Generic)--type ParentPosition = Int--data Parent = Parent-        { parentUID      :: !UID            -- my parents UID-        , parentPosition :: !ParentPosition -- my branch number (e.g. the field of a data constructor)-        } deriving (Eq,Generic)--instance Show Event where-  show e = (show . eventUID $ e) ++ ": " ++ (show . change $ e) ++ " (" ++ (show . eventParent $ e) ++ ")"--instance Show Parent where-  show p = "P " ++ (show . parentUID $ p) ++ " " ++ (show . parentPosition $ p)--root = Parent 0 0--isRootEvent :: Event -> Bool-isRootEvent e = case change e of Observe{} -> True; _ -> False--startEventStream :: IO ()-startEventStream = writeIORef events []--endEventStream :: IO Trace-endEventStream =-        do { es <- readIORef events-           ; writeIORef events badEvents -           ; return es-           }--sendEvent :: Int -> Parent -> Change -> IO ()-sendEvent nodeId parent change =-        do { let !event = Event nodeId parent change-           ; atomicModifyIORef' events (\es -> (event : es, ()))-           }---- local-events :: IORef Trace-events = unsafePerformIO $ newIORef badEvents--badEvents :: Trace-badEvents = error "Bad Event Stream"--\end{code}-  %************************************************************************ %*                                                                      *-\subsection{unique name supply code}-%*                                                                      *-%************************************************************************--Use the single threaded version--\begin{code}-type UID = Int--initUniq :: IO ()-initUniq = writeIORef uniq 1--getUniq :: IO UID-getUniq = atomicModifyIORef' uniq (\n -> (n+1,n))--peepUniq :: IO UID-peepUniq = readIORef uniq---- locals-{-# NOINLINE uniq #-}-uniq :: IORef UID-uniq = unsafePerformIO $ newIORef 1--\end{code}----%************************************************************************-%*                                                                      * \subsection{Global, initualizers, etc} %*                                                                      * %************************************************************************@@ -682,7 +760,7 @@  handleExc :: Parent -> SomeException -> IO a -- handleExc context exc = return (send "throw" (return throw << exc) context)-handleExc context exc = return (send (show exc) (return (throw exc)) context)+handleExc context exc = return (send (pack $ show exc) (return (throw exc)) context) \end{code}  %************************************************************************

@@ -1,19 +1,22 @@+{-# LANGUAGE ViewPatterns #-} -- This file is part of the Haskell debugger Hoed. -- -- Copyright (c) Maarten Faddegon 2015-2016 -{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances, StandaloneDeriving, CPP, DeriveGeneric #-}+{-# LANGUAGE OverloadedLists, DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances, StandaloneDeriving, CPP, DeriveGeneric #-}  module Debug.Hoed.Prop where -- ( judge -- , Propositions(..) -- ) where-import Debug.Hoed.Observe(Observable(..),Trace(..),UID,Event(..),Change(..),ourCatchAllIO,evaluate,eventParent,parentPosition)+import qualified Data.Vector.Generic as VG+import Debug.Hoed.Observe(EventWithId(..), Observable(..),Trace(..),UID,Event(..),Change(..),ourCatchAllIO,evaluate,eventParent,parentPosition) import Debug.Hoed.Render(CompStmt(..),noNewlines) import Debug.Hoed.CompTree(CompTree,Vertex(..),Graph(..),vertexUID,vertexRes,replaceVertex,getJudgement,setJudgement) import Debug.Hoed.EventForest(EventForest,mkEventForest,dfsChildren) import Debug.Hoed.Serialize import qualified Data.IntMap as M+import qualified Data.Text as T import Prelude hiding (Right) import Data.Graph.Libgraph(Judgement(..),AssistedMessage(..),mapGraph) import System.Directory(createDirectoryIfMissing)@@ -108,7 +111,7 @@ lookupPropositions :: [Propositions] -> Vertex -> Maybe Propositions lookupPropositions _ RootVertex = Nothing lookupPropositions ps v = lookupWith funName lbl ps-  where lbl = (stmtLabel . vertexStmt) v+  where lbl = (T.unpack . stmtLabel . vertexStmt) v  lookupWith :: Eq a => (b->a) -> a -> [b] -> Maybe b lookupWith f x ys = case filter (\y -> f y == x) ys of@@ -328,14 +331,9 @@   writeFile sourceFile prgm   return prgm   where -  prgm = generate handler prop ms trc (getEventFromMap $ eventMap trc) i f+  prgm = generate handler prop ms trc (\i -> EventWithId i (trc VG.! i)) i f   i    = (stmtIdentifier . vertexStmt) v-  f    = (stmtLabel . vertexStmt) v---getEventFromMap m j = fromJust $ M.lookup j m--eventMap trc = M.fromList $ map (\e -> (eventUID e, e)) trc+  f    = (T.unpack . stmtLabel . vertexStmt) v  mkPropRes :: Proposition -> ExitCode -> String -> PropRes mkPropRes prop (ExitFailure _) out        = Error prop out@@ -414,7 +412,7 @@  ------------------------------------------------------------------------------------------------------------------------ -generate :: UnevalHandler -> Proposition -> [Module ] -> Trace -> (UID->Event) -> UID -> String -> String+generate :: UnevalHandler -> Proposition -> [Module ] -> Trace -> (UID->EventWithId) -> UID -> String -> String generate handler prop ms trc getEvent i f = generateHeading prop ms ++ generateMain handler prop trc getEvent i f  generateHeading :: Proposition -> [Module] -> String@@ -441,7 +439,7 @@ generateImport :: Module -> String generateImport m =  "import " ++ (moduleName m) ++ "\n" -generateMain :: UnevalHandler -> Proposition -> Trace -> (UID->Event) -> UID -> String -> String+generateMain :: UnevalHandler -> Proposition -> Trace -> (UID->EventWithId) -> UID -> String -> String generateMain handler prop trc getEvent i f   = "main = Hoed.runOstore \"" ++ (propName prop) ++"\" $ "             ++ propVarBind handler (foldl accSig ((propName prop) ++ " ",unevalState handler) (signature prop)) prop@@ -465,13 +463,13 @@     cf :: PropVarGen String     cf | handler == RestrictedBottom             = foldl1 (liftPV $ \acc c -> acc ++ " " ++ c)-             [ propVarReturn $ "(" ++ genConAp (length args) f+             ([ propVarReturn $ "(" ++ genConAp (length args) f              , generateRes (unevalHandler handler) trc getEvent i              , propVarReturn $ ")"-             ]+             ] :: [PropVarGen String])        | otherwise = propVarReturn f -generateRes :: (PropVarGen String) -> Trace -> (UID -> Event) -> UID -> PropVarGen String+generateRes :: (PropVarGen String) -> Trace -> (UID -> EventWithId) -> UID -> PropVarGen String generateRes unevalGen trc getEvent i  | areFun mres = (propVarReturn " {- generateRes -} ") `pvCat`                  (generateRes unevalGen trc getEvent (eventUID . head . justFuns $ mres)) -- (*)@@ -486,10 +484,10 @@  frt = (mkEventForest trc)  e   = getEvent i -generateRes' :: PropVarGen String -> Trace -> (UID->Event) -> Maybe Event -> PropVarGen String+generateRes' :: PropVarGen String -> Trace -> (UID->EventWithId) -> Maybe EventWithId -> PropVarGen String generateRes' unevalGen trc getEvent Nothing = unevalGen generateRes' unevalGen trc getEvent (Just e)- | change e == Fun = + | change (event e) == Fun =    case dfsChildren frt e of     [_,_    ,_,mr] ->      generateRes' unevalGen trc getEvent mr@@ -502,7 +500,7 @@  where  frt = (mkEventForest trc) -generateArgs :: (PropVarGen String) -> Trace -> (UID -> Event) -> UID -> [PropVarGen String]+generateArgs :: (PropVarGen String) -> Trace -> (UID -> EventWithId) -> UID -> [PropVarGen String] generateArgs unevalGen trc getEvent i =  (propVarReturn " {- generateArgs -} ") `pvCat`  pvArg `pvCat` (propVarReturn $ " {- more: " ++ show mres ++ " -} ") @@ -522,21 +520,22 @@ nothingOrArg Nothing = True nothingOrArg (Just e) = isArg e +noArg :: [Maybe a] -> Bool noArg [Nothing] = True noArg _         = False -areFun :: [Maybe Event] -> Bool+areFun :: [Maybe EventWithId] -> Bool areFun (_:e:_) = isJustFun e areFun _       = False -justFuns :: [Maybe Event] -> [Event]-justFuns = map fromJust . filter isJustFun +justFuns :: [Maybe EventWithId] -> [EventWithId]+justFuns = map fromJust . filter isJustFun -isJustFun :: Maybe Event -> Bool-isJustFun (Just e) = change e == Fun+isJustFun :: Maybe EventWithId -> Bool+isJustFun (Just e) = change (event e) == Fun isJustFun Nothing  = False -generateFunMap :: (PropVarGen String) -> Trace -> (UID -> Event) -> [Event] -> PropVarGen String+generateFunMap :: (PropVarGen String) -> Trace -> (UID -> EventWithId) -> [EventWithId] -> PropVarGen String generateFunMap unevalGen trc getEvent funs   | length funs > 0 = caseOf `pvCat` (pvConcat cases') `pvCat` esac  | otherwise       = propVarReturn "{- a fun without applications? -}"@@ -548,7 +547,7 @@  cases  = map (\fun -> generateCase unevalGen trc getEvent fun) funs  cases' = intersperse (propVarReturn "; ") cases -generateCase :: (PropVarGen String) -> Trace -> (UID -> Event) -> Event -> PropVarGen String+generateCase :: (PropVarGen String) -> Trace -> (UID -> EventWithId) -> EventWithId -> PropVarGen String generateCase unevalGen trc getEvent fun =  (propVarReturn $ " {- CASE " ++ show fun ++ " -} ") `pvCat`  case args of @@ -571,7 +570,7 @@ isJustRes (Just e) = isRes e isJustRes Nothing  = False -hasParentPos i = (==i) . parentPosition . eventParent+hasParentPos i = (==i) . parentPosition . eventParent . event  pvCat :: PropVarGen String -> PropVarGen String -> PropVarGen String pvCat = liftPV (++)@@ -579,18 +578,18 @@ pvConcat :: [PropVarGen String] -> PropVarGen String pvConcat = foldl pvCat (propVarReturn "") -moreArgs :: PropVarGen String -> Trace -> (UID->Event) -> Maybe Event -> [PropVarGen String]+moreArgs :: PropVarGen String -> Trace -> (UID->EventWithId) -> Maybe EventWithId -> [PropVarGen String] moreArgs _ trc getEvent Nothing = [] moreArgs unevalGen trc getEvent (Just e)-  | change e == Fun = generateArgs unevalGen trc getEvent (eventUID e)+  | change (event e) == Fun = generateArgs unevalGen trc getEvent (eventUID e)   | otherwise       = [] -generateExpr :: PropVarGen String -> Trace -> (UID -> Event) -> EventForest -> Maybe Event -> PropVarGen String+generateExpr :: PropVarGen String -> Trace -> (UID -> EventWithId) -> EventForest -> Maybe EventWithId -> PropVarGen String generateExpr unevalGen _ _ _ Nothing    = unevalGen generateExpr unevalGen trc getEvent frt (Just e) =    -- (propVarReturn $ "{- generateExpr " ++ show e ++ "-}") `pvCat` -  case change e of-  (Cons _ s) -> let s' = if isAlpha (head s) then s else "(" ++ s ++ ")"+  case change (event e) of+  (Cons _ (T.unpack -> s)) -> let s' = if isAlpha (head s) then s else "(" ++ s ++ ")"                 in liftPV (++) ( foldl (liftPV $ \acc c -> acc ++ " " ++ c)                                  (propVarReturn ("(" ++ s')) cs                                ) @@ -653,7 +652,7 @@             | 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')]+            where mbs = [(catchGEq x y) `seq` (catchGEq x y), (catchGEq x' y') `seq` (catchGEq x' y')] :: [Maybe Bool]  -- Unit: used for constructors without arguments instance GParEq U1 where

@@ -1,6 +1,11 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ImplicitParams    #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists   #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- This file is part of the Haskell debugger Hoed.@@ -19,16 +24,34 @@ ,sortOn ) where import           Control.DeepSeq+import           Control.Exception        (assert)+import           Control.Monad.Primitive+import           Control.Monad.ST+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.State.Strict import           Data.Array               as Array import           Data.Char                (isAlpha)-import           Data.List                (nub, sort)-import           Data.Strict.Tuple+import           Data.Coerce+import           Data.Hashable+import           Data.List                (nub, sort, unfoldr)+import qualified Data.HashTable.ST.Cuckoo as H+import           Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import           Data.Primitive.MutVar+import           Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import           Data.Word import           Debug.Hoed.Compat import           Debug.Hoed.Observe+import           GHC.Exts(IsList(..)) import           GHC.Generics-import           Prelude                  hiding (lookup)-import           Text.PrettyPrint.FPretty hiding (sep, (<$>))-import           Text.Read+import           Text.PrettyPrint.FPretty hiding (sep, (<$>), text)+import qualified Text.PrettyPrint.FPretty as FPretty+import           Text.Read ()   ------------------------------------------------------------------------@@ -41,7 +64,7 @@ -- event that starts the observation. And stmtUIDs is the list of -- UIDs of all events that form the statement. -data CompStmt = CompStmt { stmtLabel      :: !String+data CompStmt = CompStmt { stmtLabel      :: !Text                          , stmtIdentifier :: !UID                          , stmtDetails    :: !StmtDetails                          }@@ -53,21 +76,24 @@ instance Ord CompStmt where   compare c1 c2 = compare (stmtIdentifier c1) (stmtIdentifier c2) +instance Hashable CompStmt where+  hashWithSalt s cs = hashWithSalt s (stmtIdentifier cs)+ data StmtDetails-  = StmtCon { stmtCon :: !String-           ,  stmtPretty :: !String}-  | StmtLam { stmtLamArgs :: ![String]-           ,  stmtLamRes :: !String-           ,  stmtPretty :: !String}+  = StmtCon { stmtCon :: Hashed Text+           ,  stmtPretty :: Hashed Text}+  | StmtLam { stmtLamArgs :: [Hashed Text]+           ,  stmtLamRes :: Hashed Text+           ,  stmtPretty :: Hashed Text}   deriving (Generic)  instance NFData StmtDetails -stmtRes :: CompStmt -> String-stmtRes = stmtPretty . stmtDetails+stmtRes :: CompStmt -> Text+stmtRes = unhashed . stmtPretty . stmtDetails  instance Show CompStmt where-  show = stmtRes+  show = unpack . stmtRes   showList eqs eq = unlines (map show eqs) ++ eq  noNewlines :: String -> String@@ -83,32 +109,35 @@ -- Render equations from CDS set  renderCompStmts :: (?statementWidth::Int) => CDSSet -> [CompStmt]-renderCompStmts = concatMap renderCompStmt+renderCompStmts cdss = runMemoM $ concat <$> mapM renderCompStmt cdss  -- renderCompStmt: an observed function can be applied multiple times, each application -- is rendered to a computation statement -renderCompStmt :: (?statementWidth::Int) => CDS -> [CompStmt]-renderCompStmt (CDSNamed name uid set) = statements-  where statements :: [CompStmt]-        statements   = concatMap (renderNamedTop name uid) output-        output       = cdssToOutput set+renderCompStmt :: (?statementWidth::Int) => CDS -> MemoM [CompStmt]+renderCompStmt (CDSNamed name uid set) = do+        let output = cdssToOutput set+        concat <$> mapM (renderNamedTop name uid) output  renderCompStmt other = error $ show other -renderNamedTop :: (?statementWidth::Int) => String -> UID -> Output -> [CompStmt]-renderNamedTop name observeUid (OutData cds) = map f pairs+prettySet cds = prettySet_noid(coerce cds)++prettySet_noid :: (?statementWidth::Int) => [CDSsansUID] -> MemoM(Hashed Text)+prettySet_noid = MemoM . memo (prettyW . renderSet . coerce)++renderNamedTop :: (?statementWidth::Int) => Text -> UID -> Output -> MemoM [CompStmt]+renderNamedTop name observeUid (OutData cds) = mapM f pairs   where     f (args, res, Just i) =-      CompStmt name i $-      StmtLam-        (map (prettyW . renderSet) args)-        (prettyW $ renderSet res)-        (prettyW $ renderNamedFn name (args, res))+      CompStmt name i <$>+      (StmtLam <$> mapM prettySet args <*>+       prettySet res <*>+       pure (prettyW $ renderNamedFn name (args, res)))     f (_, cons, Nothing) =-      CompStmt name observeUid $-      StmtCon (prettyW $ renderSet cons)-              (prettyW $ renderNamedCons name cons)+      CompStmt name observeUid <$>+      (StmtCon <$> prettySet cons <*>+       pure (prettyW $ renderNamedCons name cons))     pairs = (nubSorted . sortOn argAndRes) pairs'     pairs' = findFn [cds]     argAndRes (arg, res, _) = (arg, res)@@ -126,96 +155,97 @@ -- %*                                                                   * -- %************************************************************************ -data CDS = CDSNamed      !String !UID !CDSSet-         | CDSCons       !UID    !String   ![CDSSet]-         | CDSFun        !UID              !CDSSet !CDSSet+data CDS = CDSNamed      !Text !UID    !CDSSet+         | CDSCons       !UID  !Text   ![CDSSet]+         | CDSFun        !UID  !CDSSet !CDSSet          | CDSEntered    !UID          | CDSTerminated !UID+         | CDSChar       !Char   -- only used internally in eventsToCDS          | CDSString     !String -- only used internally in eventsToCDS         deriving (Show,Eq,Ord,Generic)  instance NFData CDS  normalizeCDS :: CDS -> CDS-normalizeCDS (CDSString s) = CDSCons 0 (show s) []+normalizeCDS (CDSString s) = CDSCons 0 (pack $ show s) []+normalizeCDS (CDSChar   s) = CDSCons 0 (pack $ show s) [] normalizeCDS other = other type CDSSet = [CDS] -eventsToCDS :: [Event] -> CDSSet-eventsToCDS pairs = force $ getChild 0 0-   where--     res = (!) out_arr--     bnds = (0, length pairs)+-- Monomorphized [Parent] for compactness+data ParentList = ParentCons !Int !Word8 ParentList | ParentNil+instance IsList ParentList where+  type Item ParentList = Parent+  toList = unfoldr (\case ParentNil -> Nothing ; ParentCons pp pc t -> Just (Parent pp pc,t))+  fromList = foldr (\(Parent pp pc) t -> ParentCons pp pc t) ParentNil -     cons !t !h = h : t+eventsToCDS :: Trace -> CDSSet+eventsToCDS pairs = getChild (-1) 0+   where -     mid_arr :: Array Int [Pair Int CDS]-     mid_arr = accumArray cons [] bnds-                [ (pnode, (pport :!: res node))-                | (Event node (Parent pnode pport) change) <- pairs-                , change /= Enter-                ]+     -- res i = out_arr VG.! i+     res i = getNode'' i (change (pairs VG.! i)) -     out_arr = array bnds       -- never uses 0 index-                [ (node,getNode'' node e change)-                | e@(Event node _ change) <- pairs-                ]+     mid_arr :: V.Vector ParentList+     mid_arr = VG.unsafeAccumulate+                  (\i (Parent pp pc) -> ParentCons pp pc i)+                  (V.replicate (VG.length pairs) ParentNil)+                  ( VG.map (\(node, Event (Parent pnode pport) _) ->+                              (pnode+1, Parent node pport))+                  $ VG.filter (\(_,e) -> change e /= Enter)+                  $ VG.convert+                  $ VG.indexed pairs) -     getNode'' ::  Int -> Event -> Change -> CDS-     getNode'' node _e change =+     getNode'' ::  Int -> Change -> CDS+     getNode'' node change =        case change of         Observe str         -> let chd = normalizeCDS <$> getChild node 0                                in CDSNamed str (getId chd node) chd         Enter               -> CDSEntered node         Fun                 -> CDSFun node (normalizeCDS <$> getChild node 0)                                            (normalizeCDS <$> getChild node 1)-        (Cons portc cons)+        ConsChar char       -> CDSChar char+        Cons portc cons                             -> simplifyCons node cons-                                 [getChild node n | n <- [0 .. portc - 1]]+                                 [ getChild node (fromIntegral n)+                                 | n <- [0::Int .. fromIntegral portc - 1]]       getId []                 i  = i      getId (CDSFun i _ _:_) _    = i      getId (_:cs)             i  = getId cs i -     getChild :: Int -> Int -> CDSSet+     getChild :: Int -> Word8 -> CDSSet      getChild pnode pport =-       [ content-       | pport' :!: content <- (!) mid_arr pnode+       [ res content+       | Parent content pport' <- toList $ mid_arr VG.! succ pnode        , pport == pport'        ] -simplifyCons :: UID -> String -> [CDSSet] -> CDS+simplifyCons :: UID -> Text -> [CDSSet] -> CDS simplifyCons _ "throw" [[CDSCons _ "ErrorCall" set]]   = CDSCons 0 "error" set-simplifyCons _ ":" [[CDSCons _ (matchChar -> Just !ch) []], [CDSCons _ "[]" []]]+simplifyCons _ ":" [[CDSChar !ch], [CDSCons _ "[]" []]]   = CDSString [ch]-simplifyCons _ ":" [[CDSCons _ (matchChar -> Just !ch) []], [CDSString s]]+simplifyCons _ ":" [[CDSChar !ch], [CDSString s]]   = CDSString (ch:s) simplifyCons uid con xx = CDSCons uid con (map (map normalizeCDS) xx) -matchChar :: [Char] -> Maybe Char-matchChar ['\'', ch ,'\''] = Just ch-matchChar special@['\'', _, _ ,'\''] = readMaybe special-matchChar _ = Nothing--render  :: Int -> Bool -> CDS -> Doc+render :: Int -> Bool -> CDS -> Doc render prec par (CDSCons _ ":" [cds1,cds2]) =         if par && not needParen         then doc -- dont use paren (..) because we dont want a grp here!         else paren needParen doc    where-        doc = grp (sep <> renderSet' 5 False cds1 <> " : ") <>+        doc = grp (renderSet' 5 False cds1 <> text " : ") <>               renderSet' 4 True cds2         needParen = prec > 4-render _prec _par (CDSCons _ "," cdss) | not (null cdss) =-        nest 2 ("(" <> foldl1 (\ a b -> a <> ", " <> b)+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)-  | _:_ <- name-  , (not . isAlpha . head) name && length cdss > 1 = -- render as infix+  | not (T.null name)+  , (not . isAlpha . T.head) name && length cdss > 1 = -- render as infix         paren (prec /= 0)                   (grp                     (renderSet' 10 False (head cdss)@@ -245,13 +275,13 @@ renderSet = renderSet' 0 False  renderSet' :: Int -> Bool -> CDSSet -> Doc-renderSet' _ _      [] = "_"-renderSet' prec par [cons@CDSCons {}]    = render prec par cons-renderSet' _prec _par cdss                   =-         "{ " <> foldl1 (\ a b -> a <> line <>-                                    ", " <> b)+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 pairs) <>-                line <> "}"+                line <> text "}")     where         findFn_noUIDs :: CDSSet -> [([CDSSet],CDSSet)]@@ -265,21 +295,21 @@ renderFn :: ([CDSSet],CDSSet) -> Doc renderFn (args, res)         = grp  (nest 3-                ("\\ " <>+                (text "\\ " <>                  foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)                        nil-                       args <> sep <>-                 "-> " <> renderSet res+                       args <> softline <>+                 text "-> " <> renderSet' 0 False res                 )                ) -renderNamedCons :: String -> CDSSet -> Doc+renderNamedCons :: Text -> CDSSet -> Doc renderNamedCons name cons   = text name <> nest 2      ( sep <> grp (text "= " <> renderSet cons)      ) -renderNamedFn :: String -> ([CDSSet],CDSSet) -> Doc+renderNamedFn :: Text -> ([CDSSet],CDSSet) -> Doc renderNamedFn name (args,res)   = text name <> nest 2      ( sep <> foldr (\ a b -> grp (renderSet' 10 False a) <> sep <> b) nil args@@ -302,10 +332,10 @@ findFn' other rest = ([],[other], Nothing) : rest  paren :: Bool -> Doc -> Doc-paren False doc = grp doc-paren True  doc = grp ( "(" <> doc <> ")")+paren False doc = grp (nest 0 doc)+paren True  doc = grp (text "(" <> doc <> text ")") -data Output = OutLabel String CDSSet [Output]+data Output = OutLabel Text CDSSet [Output]             | OutData  CDS               deriving (Eq,Ord,Show) @@ -329,7 +359,63 @@ sep :: Doc sep = softline  -- A space, if the following still fits on the current line, otherwise newline. sp :: Doc-sp = " "   -- A space, always.+sp = text " "   -- A space, always. -prettyW :: (?statementWidth::Int) => Doc -> String-prettyW = pretty ?statementWidth+-- TODO fork FPretty to build on Text instead of Strings+text = FPretty.text . unpack++prettyW :: (?statementWidth::Int) => Doc -> (Hashed Text)+prettyW doc = hashed $ pack $ pretty ?statementWidth doc++-- %************************************************************************+-- %*                                                                   *+-- \subsection{Custom Eq and Ord instances for CDS that gloss over UIDs}+-- %*                                                                   *+-- %************************************************************************++newtype CDSsansUID = CDSsansUID CDS++instance Eq CDSsansUID where+  CDSsansUID(CDSNamed t _ xx) == CDSsansUID(CDSNamed t' _ yy) =+    t == t' && coerce xx == (coerce yy :: [CDSsansUID])+  CDSsansUID (CDSCons _ t xx) == CDSsansUID(CDSCons _ t' yy)  =+    t == t'  && coerce xx == (coerce yy :: [[CDSsansUID]])+  CDSsansUID (CDSFun _ res args) == CDSsansUID (CDSFun _ res' args') =+    (coerce res :: [CDSsansUID]) == coerce res' && coerce args == (coerce args' :: [CDSsansUID])+  CDSsansUID x == CDSsansUID y = x == y++instance Ord CDSsansUID where+  CDSsansUID (CDSNamed t _ xx) `compare` CDSsansUID (CDSNamed t' _ yy) =+    (t, coerce xx :: [CDSsansUID]) `compare` (t', coerce yy)+  CDSsansUID (CDSCons _ t xx) `compare` CDSsansUID (CDSCons _ t' yy) =+    (t, coerce xx :: [[CDSsansUID]]) `compare` (t', coerce yy)+  CDSsansUID (CDSFun _ args res) `compare` CDSsansUID (CDSFun _ args' res') =+    (coerce args :: [CDSsansUID], coerce res :: [CDSsansUID]) `compare` (coerce args', coerce res')+  CDSsansUID x `compare` CDSsansUID y = x `compare` y++instance Hashable CDSsansUID where+  s `hashWithSalt` CDSsansUID (CDSNamed t _ xx) = s `hashWithSalt` t `hashWithSalt` (coerce xx :: [CDSsansUID])+  s `hashWithSalt` CDSsansUID (CDSCons _  t xx) = s `hashWithSalt` t `hashWithSalt` (coerce xx :: [[CDSsansUID]])+  s `hashWithSalt` CDSsansUID (CDSFun _ args res) = s `hashWithSalt` (coerce args :: [CDSsansUID]) `hashWithSalt` (coerce res :: [CDSsansUID])+++-- %************************************************************************+-- %*                                                                   *+-- \subsection{Memoization of pretty calls}+-- %*                                                                   *+-- %************************************************************************++newtype MemoM a = MemoM (State (Map [CDSsansUID] (Hashed Text)) a) deriving (Applicative, Functor, Monad)++runMemoM :: MemoM a -> a+runMemoM (MemoM comp) = evalState comp mempty++memo :: Ord a => (a->b) -> a -> State (Map a b) b+memo f a = do+  table <- get+  case Map.lookup a table of+    Just b -> return b+    Nothing -> do+      let b = f a+      modify (Map.insert a b)+      return b

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances #-} -- This file is part of the Haskell debugger Hoed. -- -- Copyright (c) Maarten Faddegon, 2016@@ -16,8 +17,13 @@ import qualified Prelude as Prelude import Debug.Hoed.CompTree import Debug.Hoed.Render(CompStmt(..), StmtDetails(..))+import Data.Hashable import Data.Serialize+import Data.Serialize.Text+import Data.Vector.Serialize+ import qualified Data.ByteString as BS+import GHC.Exts (IsList(..)) import GHC.Generics import Data.Graph.Libgraph(Judgement(..),AssistedMessage(..),mapGraph,Graph(..),Arc(..)) @@ -35,6 +41,9 @@ instance Serialize Parent instance Serialize Event instance Serialize Change+instance (Hashable a, Serialize a) => Serialize (Hashed a) where+  get = hashed <$> get+  put = put . unhashed  -------------------------------------------------------------------------------- -- Tree

@@ -6,7 +6,9 @@ import           Control.Monad import           Data.Generics.Uniplate.Data import           Data.List                   (group, nub, sort, (\\))+import           Data.Text (pack) import           Debug.Hoed+import           Debug.Hoed import           Debug.Hoed.Compat import           Language.Haskell.TH import           Language.Haskell.TH.Syntax@@ -40,7 +42,7 @@       FunD n xx -> do         let Just n' = lookup n names             nb = nameBase n-        newDecl <- funD n [clause [] (normalB [| observe nb $(varE n')|]) []]+        newDecl <- funD n [clause [] (normalB [| observe (pack nb) $(varE n')|]) []]         return [newDecl, FunD n' xx]       SigD n ty | Just n' <- lookup n names -> do         dec' <- adjustSig n ty@@ -78,7 +80,7 @@       FunD n clauses -> do         let Just n' = lookup n names             nb = nameBase n-        newDecl <- funD n [clause [] (normalB [| observe nb $(varE n')|]) []]+        newDecl <- funD n [clause [] (normalB [| observe (pack nb) $(varE n')|]) []]         let clauses' = transformBi adjustValD clauses         return [newDecl, FunD n' clauses']       SigD n ty | Just n' <- lookup n names -> do@@ -111,7 +113,7 @@ adjustValD decl@ValD{} = transformBi adjustPat decl adjustValD other       = other -adjustPat (VarP x) = ViewP (VarE 'observe `AppE` toLit x) (VarP x)+adjustPat (VarP x) = ViewP (VarE 'observe `AppE` (VarE 'pack `AppE` toLit x)) (VarP x) adjustPat x        = x  toLit (Name (OccName x) _) = LitE $ StringL x

@@ -0,0 +1,35 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Debug.Hoed.Util where++import System.Clock+import System.IO++data Verbosity = Verbose | Silent++-- | Conditional output to stderr+condPutStr :: Verbosity -> String -> IO ()+condPutStr Silent _    = return ()+condPutStr Verbose msg = hPutStr stderr msg++-- | Conditional output to stderr+condPutStrLn :: Verbosity -> String -> IO ()+condPutStrLn Silent _    = return ()+condPutStrLn Verbose msg = hPutStrLn stderr msg++--------------------------------------------+-- Measuring elapsed time++newtype Seconds = Seconds Double deriving (Eq, Ord, Num)++instance Show Seconds where+  show (Seconds s) = show s ++ " seconds"++stopWatch :: IO (IO Seconds)+stopWatch  = do+  t <- getTime Monotonic+  return $ do+    t' <- getTime Monotonic+    return (toSecs(diffTimeSpec t t'))+  where+       toSecs :: TimeSpec -> Seconds+       toSecs spec = Seconds $ fromIntegral(sec spec) + fromIntegral(nsec spec) * 1e-9

@@ -1,5 +1,5 @@ name:                Hoed-version:             0.4.1+version:             0.5.0 synopsis:            Lightweight algorithmic debugging. description:     Hoed is a tracer and debugger for the programming language Haskell.@@ -36,6 +36,8 @@                        , Debug.Hoed.Prop                        , Debug.Hoed.Serialize                        , Debug.Hoed.Span+                       , Debug.Hoed.Util+                       , Data.Rope.Mutable                        , Text.PrettyPrint.FPretty                        , Paths_Hoed   build-depends:       base >= 4 && <5@@ -45,15 +47,24 @@                        , process                        , libgraph == 1.14                        , regex-tdfa+                       , regex-tdfa-text                        , directory-                       , cereal, bytestring+                       , bytestring+                       , cereal, cereal-text, cereal-vector+                       , hashable >= 1.2.5+                       , hashtables                        , QuickCheck+                       , open-browser+                       , primitive                        , semigroups                        , strict                        , template-haskell                        , terminal-size+                       , text+                       , transformers                        , uniplate                        , vector+                       , vector-th-unbox   default-language:    Haskell2010  Test-Suite test-queens@@ -65,6 +76,7 @@                     , QuickCheck                     , Hoed   default-language: Haskell2010+  ghc-options:         -rtsopts  Test-Suite test-1   type:             exitcode-stdio-1.0@@ -112,5 +124,12 @@   type:             exitcode-stdio-1.0   hs-source-dirs:   tests/Pure/   main-is:          t7.hs+  build-depends:    base >= 4 && <5, QuickCheck, Hoed, process+  default-language: Haskell2010++Test-Suite test-th+  type:             exitcode-stdio-1.0+  hs-source-dirs:   tests/TH+  main-is:          quicksort.hs   build-depends:    base >= 4 && <5, QuickCheck, Hoed, process   default-language: Haskell2010

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Safe, CPP #-}  -- | @@ -115,6 +116,7 @@ import Prelude hiding ((<$>)) #endif +import Data.Hashable import Data.Maybe (fromJust) import Data.Sequence as Dequeue (Seq, (<|), viewl, viewr, ViewL(..), ViewR(..)) import qualified Data.Sequence as Dequeue (empty)@@ -123,6 +125,7 @@   -- Efficiency probably similar, but Data.Sequence is part of the standard Haskell    -- libraries. import Data.String+import GHC.Generics  infixr 6 <>,<+> infixr 5 <$>,<$$>,</>,<//>@@ -247,7 +250,9 @@          | Group Doc          | Nest Int Doc     -- increase current indentation          | Align Int Doc    -- set indentation to current column plus increment-  deriving Show+  deriving (Eq, Generic, Ord, Show)++instance Hashable Doc  instance IsString Doc where   fromString = text

@@ -1,3 +1,15 @@+0.5.0 Maarten Faddegon 28 Jan 2018++  * Improved rendering of parens in computation statements+  * A graph command contributed by Pepe Iborra+  * Space improvements contributed by Pepe Iborra++0.4.1 Maarten Faddegon 20 Jan 2018++  * Improved documentation for the new interface+  * Several bugfixes contributed by Pepe Iborra+  * Performance improvement contributed by Pepe Iborra+ 0.4.0 Maarten Faddegon 9 Sep 2017    * Text based interface to the debugger for closer integration with an interpreter (e.g. ghci)

@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} module Queens where -- The queens problem made famous by Wirth. import Debug.Hoed

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} import Debug.Hoed import System.Process(system) import System.Exit(exitWith)

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} import Debug.Hoed import System.Process(system) import System.Exit(exitWith)

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- Haskell version of the buggy insertion sort as shown in Lee Naish -- A Declarative Debugging Scheme. 

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- A defective implementation of a parity function with a test property.  import Debug.Hoed

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} import Debug.Hoed import System.Process(system) import System.Exit(exitWith)

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} module Main where import Debug.Hoed

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} import Debug.Hoed import System.Process(system) import System.Exit(exitWith)

@@ -0,0 +1,26 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+import Data.List (partition)+import Debug.Hoed+import Debug.Hoed.TH+import System.Process+import System.Exit++obs [d|+  quicksort :: (a -> a -> Bool) -> [a] -> [a]+  quicksort op [] = []+  quicksort op (x:xs) = quicksort op lt ++ [x] ++ quicksort op gt+    where (lt, gt) = partition (`op` x) xs+        |]++debug [d|+  quicksort' :: (a -> a -> Bool) -> [a] -> [a]+  quicksort' op [] = []+  quicksort' op (x:xs) = quicksort' op lt ++ [x] ++ quicksort' op gt+    where (lt, gt) = partition (`op` x) xs+        |]++main = logO "hoed-tests-th-quicksort.graph" $ do+  print $ quicksort  (<) "haskell"+  print $ quicksort' (<) "haskell"+  exitWith =<< system "diff hoed-tests-th-quicksort.graph tests/ref/hoed-tests-th-quicksort.graph"

@@ -1,9 +1,9 @@ diGraph G {-v3 [label="g 2 = 1"]+v3 [label="f 2 = 1"] v2 [label="f 0 = 0"]-v1 [label="f 2 = 1"]+v1 [label="g 2 = 1"] v0 [label="."shape=none]-v1 -> v3 [label=""]+v3 -> v1 [label=""] v0 -> v2 [label=""]-v0 -> v1 [label=""]+v0 -> v3 [label=""] }

@@ -1,15 +1,15 @@ diGraph G {-v6 [label="n 2 = 2"]-v5 [label="n 1 = 1"]-v4 [label="m 2 = 2"]-v3 [label="m 1 = 1"]-v2 [label="l 1 = 1"]-v1 [label="k 1 = 3"]+v6 [label="k 1 = 3"]+v5 [label="l 1 = 1"]+v4 [label="m 1 = 1"]+v3 [label="m 2 = 2"]+v2 [label="n 1 = 1"]+v1 [label="n 2 = 2"] v0 [label="."shape=none]-v4 -> v6 [label=""]-v3 -> v5 [label=""]-v2 -> v3 [label=""]-v1 -> v4 [label=""]-v1 -> v2 [label=""]-v0 -> v1 [label=""]+v3 -> v1 [label=""]+v4 -> v2 [label=""]+v5 -> v4 [label=""]+v6 -> v3 [label=""]+v6 -> v5 [label=""]+v0 -> v6 [label=""] }

@@ -1,13 +1,13 @@ diGraph G {-v5 [label="insert 2 [] = 2 : []"]-v4 [label="insert 1 ( 2 : []) = 1 : []"]+v5 [label="isort (1 : 2 : []) = 1 : []"]+v4 [label="isort (2 : []) = 2 : []"] v3 [label="isort [] = []"]-v2 [label="isort ( 2 : []) = 2 : []"]-v1 [label="isort ( 1 : 2 : []) = 1 : []"]+v2 [label="insert 1 (2 : []) = 1 : []"]+v1 [label="insert 2 [] = 2 : []"] v0 [label="."shape=none]-v2 -> v3 [label=""]-v2 -> v5 [label=""]-v1 -> v2 [label=""]-v1 -> v4 [label=""]-v0 -> v1 [label=""]+v4 -> v3 [label=""]+v4 -> v1 [label=""]+v5 -> v4 [label=""]+v5 -> v2 [label=""]+v0 -> v5 [label=""] }

@@ -1,11 +1,11 @@ diGraph G {-v4 [label="plusOne 3 = 4"]-v3 [label="mod2 4 = 2"]-v2 [label="isEven 4 = False"]-v1 [label="isOdd 3 = False"]+v4 [label="isOdd 3 = False"]+v3 [label="isEven 4 = False"]+v2 [label="mod2 4 = 2"]+v1 [label="plusOne 3 = 4"] v0 [label="."shape=none]-v2 -> v3 [label=""]-v1 -> v4 [label=""]-v1 -> v2 [label=""]-v0 -> v1 [label=""]+v3 -> v2 [label=""]+v4 -> v1 [label=""]+v4 -> v3 [label=""]+v0 -> v4 [label=""] }

@@ -1,7 +1,7 @@ diGraph G {-v2 [label="g 3 = 6"]-v1 [label="f (Just 3) = 6"]+v2 [label="f (Just 3) = 6"]+v1 [label="g 3 = 6"] v0 [label="."shape=none]-v1 -> v2 [label=""]-v0 -> v1 [label=""]+v2 -> v1 [label=""]+v0 -> v2 [label=""] }

@@ -1,7 +1,7 @@ diGraph G {-v2 [label="apxy { \\ 4 5 -> 9 } 4 5 = 9"]-v1 [label="ap45 { \\ 4 5 -> 9 } = 9"]+v2 [label="ap45 { \\ 4 5 -> 9 } = 9"]+v1 [label="apxy { \\ 4 5 -> 9 } 4 5 = 9"] v0 [label="."shape=none]-v1 -> v2 [label=""]-v0 -> v1 [label=""]+v2 -> v1 [label=""]+v0 -> v2 [label=""] }

@@ -0,0 +1,91 @@+diGraph G {+v44 [label="quicksort { \\ 'a' 'h' -> True , \\ 'e' 'a' -> False , \\ 'e' 'h' -> True , \\ 'k' 'h' -> False , \\ 'k' 's' -> True , \\ 'l' 'h' -> False , \\ 'l' 'h' -> False , \\ 'l' 'k' -> False , \\ 'l' 'k' -> False , \\ 'l' 'l' -> False , \\ 'l' 's' -> True , \\ 'l' 's' -> True , \\ 's' 'h' -> False } \"haskell\" = \"aehklls\""]+v43 [label="quicksort { \\ 'e' 'a' -> False } \"ae\" = \"ae\""]+v42 [label="quicksort _ [] = []"]+v41 [label="quicksort _ \"e\" = \"e\""]+v40 [label="quicksort _ [] = []"]+v39 [label="quicksort _ [] = []"]+v38 [label="quicksort { \\ 'k' 's' -> True , \\ 'l' 'k' -> False , \\ 'l' 'k' -> False , \\ 'l' 'l' -> False , \\ 'l' 's' -> True , \\ 'l' 's' -> True } \"skll\" = \"klls\""]+v37 [label="quicksort { \\ 'l' 'k' -> False , \\ 'l' 'k' -> False , \\ 'l' 'l' -> False } \"kll\" = \"kll\""]+v36 [label="quicksort _ [] = []"]+v35 [label="quicksort { \\ 'l' 'l' -> False } \"ll\" = \"ll\""]+v34 [label="quicksort _ [] = []"]+v33 [label="quicksort _ \"l\" = \"l\""]+v32 [label="quicksort _ [] = []"]+v31 [label="quicksort _ [] = []"]+v30 [label="quicksort _ [] = []"]+v29 [label="quicksort' { \\ 'a' 'h' -> True , \\ 'e' 'a' -> False , \\ 'e' 'h' -> True , \\ 'k' 'h' -> False , \\ 'k' 's' -> True , \\ 'l' 'h' -> False , \\ 'l' 'h' -> False , \\ 'l' 'k' -> False , \\ 'l' 'k' -> False , \\ 'l' 'l' -> False , \\ 'l' 's' -> True , \\ 'l' 's' -> True , \\ 's' 'h' -> False } \"haskell\" = \"aehklls\""]+v28 [label="quicksort' { \\ 'e' 'a' -> False } \"ae\" = \"ae\""]+v27 [label="quicksort' _ [] = []"]+v26 [label="quicksort' _ \"e\" = \"e\""]+v25 [label="quicksort' _ [] = []"]+v24 [label="quicksort' _ [] = []"]+v23 [label="quicksort' { \\ 'k' 's' -> True , \\ 'l' 'k' -> False , \\ 'l' 'k' -> False , \\ 'l' 'l' -> False , \\ 'l' 's' -> True , \\ 'l' 's' -> True } \"skll\" = \"klls\""]+v22 [label="quicksort' { \\ 'l' 'k' -> False , \\ 'l' 'k' -> False , \\ 'l' 'l' -> False } \"kll\" = \"kll\""]+v21 [label="quicksort' _ [] = []"]+v20 [label="quicksort' { \\ 'l' 'l' -> False } \"ll\" = \"ll\""]+v19 [label="quicksort' _ [] = []"]+v18 [label="quicksort' _ \"l\" = \"l\""]+v17 [label="quicksort' _ [] = []"]+v16 [label="quicksort' _ [] = []"]+v15 [label="quicksort' _ [] = []"]+v14 [label="lt = \"ae\""]+v13 [label="lt = []"]+v12 [label="gt = \"e\""]+v11 [label="lt = []"]+v10 [label="gt = []"]+v9 [label="gt = \"skll\""]+v8 [label="lt = \"kll\""]+v7 [label="lt = []"]+v6 [label="gt = \"ll\""]+v5 [label="lt = []"]+v4 [label="gt = \"l\""]+v3 [label="lt = []"]+v2 [label="gt = []"]+v1 [label="gt = []"]+v0 [label="."shape=none]+v18 -> v2 [label=""]+v18 -> v16 [label=""]+v18 -> v3 [label=""]+v18 -> v17 [label=""]+v20 -> v4 [label=""]+v20 -> v18 [label=""]+v20 -> v5 [label=""]+v20 -> v19 [label=""]+v22 -> v6 [label=""]+v22 -> v20 [label=""]+v22 -> v7 [label=""]+v22 -> v21 [label=""]+v23 -> v1 [label=""]+v23 -> v15 [label=""]+v23 -> v8 [label=""]+v23 -> v22 [label=""]+v26 -> v10 [label=""]+v26 -> v24 [label=""]+v26 -> v11 [label=""]+v26 -> v25 [label=""]+v28 -> v12 [label=""]+v28 -> v26 [label=""]+v28 -> v13 [label=""]+v28 -> v27 [label=""]+v29 -> v9 [label=""]+v29 -> v23 [label=""]+v29 -> v14 [label=""]+v29 -> v28 [label=""]+v33 -> v31 [label=""]+v33 -> v32 [label=""]+v35 -> v33 [label=""]+v35 -> v34 [label=""]+v37 -> v35 [label=""]+v37 -> v36 [label=""]+v38 -> v30 [label=""]+v38 -> v37 [label=""]+v41 -> v39 [label=""]+v41 -> v40 [label=""]+v43 -> v41 [label=""]+v43 -> v42 [label=""]+v44 -> v38 [label=""]+v44 -> v43 [label=""]+v0 -> v29 [label=""]+v0 -> v44 [label=""]+}