diff --git a/Data/Rope/Mutable.hs b/Data/Rope/Mutable.hs new file mode 100644 --- /dev/null +++ b/Data/Rope/Mutable.hs @@ -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') diff --git a/Debug/Hoed.hs b/Debug/Hoed.hs --- a/Debug/Hoed.hs +++ b/Debug/Hoed.hs @@ -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" diff --git a/Debug/Hoed/CompTree.hs b/Debug/Hoed/CompTree.hs --- a/Debug/Hoed/CompTree.hs +++ b/Debug/Hoed/CompTree.hs @@ -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 diff --git a/Debug/Hoed/Console.hs b/Debug/Hoed/Console.hs --- a/Debug/Hoed/Console.hs +++ b/Debug/Hoed/Console.hs @@ -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 - - - - diff --git a/Debug/Hoed/EventForest.hs b/Debug/Hoed/EventForest.hs --- a/Debug/Hoed/EventForest.hs +++ b/Debug/Hoed/EventForest.hs @@ -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 diff --git a/Debug/Hoed/Observe.lhs b/Debug/Hoed/Observe.lhs --- a/Debug/Hoed/Observe.lhs +++ b/Debug/Hoed/Observe.lhs @@ -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 (" " ++ show e) (return e) + observer e = send (" " <> 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} %************************************************************************ diff --git a/Debug/Hoed/Prop.hs b/Debug/Hoed/Prop.hs --- a/Debug/Hoed/Prop.hs +++ b/Debug/Hoed/Prop.hs @@ -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 diff --git a/Debug/Hoed/Render.hs b/Debug/Hoed/Render.hs --- a/Debug/Hoed/Render.hs +++ b/Debug/Hoed/Render.hs @@ -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 diff --git a/Debug/Hoed/Serialize.hs b/Debug/Hoed/Serialize.hs --- a/Debug/Hoed/Serialize.hs +++ b/Debug/Hoed/Serialize.hs @@ -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 diff --git a/Debug/Hoed/TH.hs b/Debug/Hoed/TH.hs --- a/Debug/Hoed/TH.hs +++ b/Debug/Hoed/TH.hs @@ -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 diff --git a/Debug/Hoed/Util.hs b/Debug/Hoed/Util.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Util.hs @@ -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 diff --git a/Hoed.cabal b/Hoed.cabal --- a/Hoed.cabal +++ b/Hoed.cabal @@ -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 diff --git a/Text/PrettyPrint/FPretty.hs b/Text/PrettyPrint/FPretty.hs --- a/Text/PrettyPrint/FPretty.hs +++ b/Text/PrettyPrint/FPretty.hs @@ -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 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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) diff --git a/examples/Queens__with_properties/Queens.hs b/examples/Queens__with_properties/Queens.hs --- a/examples/Queens__with_properties/Queens.hs +++ b/examples/Queens__with_properties/Queens.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} module Queens where -- The queens problem made famous by Wirth. import Debug.Hoed diff --git a/tests/Pure/t1.hs b/tests/Pure/t1.hs --- a/tests/Pure/t1.hs +++ b/tests/Pure/t1.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} import Debug.Hoed import System.Process(system) import System.Exit(exitWith) diff --git a/tests/Pure/t2.hs b/tests/Pure/t2.hs --- a/tests/Pure/t2.hs +++ b/tests/Pure/t2.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} import Debug.Hoed import System.Process(system) import System.Exit(exitWith) diff --git a/tests/Pure/t3.hs b/tests/Pure/t3.hs --- a/tests/Pure/t3.hs +++ b/tests/Pure/t3.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- Haskell version of the buggy insertion sort as shown in Lee Naish -- A Declarative Debugging Scheme. diff --git a/tests/Pure/t4.hs b/tests/Pure/t4.hs --- a/tests/Pure/t4.hs +++ b/tests/Pure/t4.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- A defective implementation of a parity function with a test property. import Debug.Hoed diff --git a/tests/Pure/t5.hs b/tests/Pure/t5.hs --- a/tests/Pure/t5.hs +++ b/tests/Pure/t5.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} import Debug.Hoed import System.Process(system) import System.Exit(exitWith) diff --git a/tests/Pure/t6.hs b/tests/Pure/t6.hs --- a/tests/Pure/t6.hs +++ b/tests/Pure/t6.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} module Main where import Debug.Hoed diff --git a/tests/Pure/t7.hs b/tests/Pure/t7.hs --- a/tests/Pure/t7.hs +++ b/tests/Pure/t7.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} import Debug.Hoed import System.Process(system) import System.Exit(exitWith) diff --git a/tests/TH/quicksort.hs b/tests/TH/quicksort.hs new file mode 100644 --- /dev/null +++ b/tests/TH/quicksort.hs @@ -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" diff --git a/tests/ref/hoed-tests-Pure-t1.graph b/tests/ref/hoed-tests-Pure-t1.graph --- a/tests/ref/hoed-tests-Pure-t1.graph +++ b/tests/ref/hoed-tests-Pure-t1.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=""] } diff --git a/tests/ref/hoed-tests-Pure-t2.graph b/tests/ref/hoed-tests-Pure-t2.graph --- a/tests/ref/hoed-tests-Pure-t2.graph +++ b/tests/ref/hoed-tests-Pure-t2.graph @@ -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=""] } diff --git a/tests/ref/hoed-tests-Pure-t3.graph b/tests/ref/hoed-tests-Pure-t3.graph --- a/tests/ref/hoed-tests-Pure-t3.graph +++ b/tests/ref/hoed-tests-Pure-t3.graph @@ -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=""] } diff --git a/tests/ref/hoed-tests-Pure-t4.graph b/tests/ref/hoed-tests-Pure-t4.graph --- a/tests/ref/hoed-tests-Pure-t4.graph +++ b/tests/ref/hoed-tests-Pure-t4.graph @@ -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=""] } diff --git a/tests/ref/hoed-tests-Pure-t5.graph b/tests/ref/hoed-tests-Pure-t5.graph --- a/tests/ref/hoed-tests-Pure-t5.graph +++ b/tests/ref/hoed-tests-Pure-t5.graph @@ -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=""] } diff --git a/tests/ref/hoed-tests-Pure-t7.graph b/tests/ref/hoed-tests-Pure-t7.graph --- a/tests/ref/hoed-tests-Pure-t7.graph +++ b/tests/ref/hoed-tests-Pure-t7.graph @@ -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=""] } diff --git a/tests/ref/hoed-tests-th-quicksort.graph b/tests/ref/hoed-tests-th-quicksort.graph new file mode 100644 --- /dev/null +++ b/tests/ref/hoed-tests-th-quicksort.graph @@ -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=""] +}