hood 0.2 → 0.2.1
raw patch · 5 files changed
+360/−337 lines, 5 filesdep ~basenew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Debug.Hood.Observe: instance Applicative ObserverM
+ Debug.Hood.Observe: instance Functor ObserverM
- Debug.Hood.Observe: class Observable a
+ Debug.Hood.Observe: class Observable a where observers label arg = defaultObservers label arg
Files
- CHANGELOG.md +2/−0
- Debug/Hood/Observe.lhs +344/−332
- LICENSE +1/−1
- README.md +3/−0
- hood.cabal +10/−4
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+## 0.2.1+* Fixed build with GHC 7.10
Debug/Hood/Observe.lhs view
@@ -27,49 +27,50 @@ %************************************************************************-%* *+%* * \subsection{Exports}-%* *+%* * %************************************************************************ \begin{code}-module Debug.Hood.Observe +module Debug.Hood.Observe ( -- * The main Hood API- - observe -- (Observable a) => String -> a -> a++ observe -- (Observable a) => String -> a -> a , Observer(..) -- contains a 'forall' typed observe (if supported). , Observing -- a -> a , Observable(..) -- Class- , runO -- IO a -> IO ()- , printO -- a -> IO ()- , putStrO -- String -> IO ()+ , runO -- IO a -> IO ()+ , printO -- a -> IO ()+ , putStrO -- String -> IO () -- * For advanced users, that want to render their own datatypes. , (<<) -- (Observable a) => ObserverM (a -> b) -> a -> ObserverM b- , thunk -- (Observable a) => a -> ObserverM a + , thunk -- (Observable a) => a -> ObserverM a , send , observeBase , observeOpaque -- * For users that want to write there own render drivers.- - , debugO -- IO a -> IO [CDS]++ , debugO -- IO a -> IO [CDS] , CDS(..)- ) where + ) where \end{code} %************************************************************************-%* *+%* * \subsection{Imports and infixing}-%* *+%* * %************************************************************************ \begin{code} import System.IO import Data.Maybe+import Control.Applicative import Control.Monad import Data.Array as Array import Data.List@@ -90,22 +91,26 @@ import qualified Control.Exception as Exception {- ( catch- , Exception(..)- , throw- ) as Exception+ , Exception(..)+ , throw+ ) as Exception -} import Data.Dynamic ( Dynamic ) \end{code} \begin{code}+import Prelude+\end{code}++\begin{code} infixl 9 << \end{code} %************************************************************************-%* *+%* * \subsection{External start functions}-%* *+%* * %************************************************************************ Run the observe ridden code.@@ -113,30 +118,30 @@ \begin{code} -- | run some code and return the CDS structure (for when you want to write your own debugger). debugO :: IO a -> IO [CDS]-debugO program = +debugO program = do { initUniq- ; startEventStream+ ; startEventStream ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"- ; ourCatchAllIO (do { program ; return () }) - (hPutStrLn stderr . errorMsg)+ ; ourCatchAllIO (do { program ; return () })+ (hPutStrLn stderr . errorMsg) ; events <- endEventStream- ; return (eventsToCDS events)- }+ ; return (eventsToCDS events)+ } --- | print a value, with debugging +-- | print a value, with debugging printO :: (Show a) => a -> IO () printO expr = runO (print expr) --- | print a string, with debugging +-- | print a string, with debugging putStrO :: String -> IO () putStrO expr = runO (putStr expr) -- | The main entry point; run some IO code, and debug inside it.--- --- An example of using this debugger is --+-- An example of using this debugger is+-- -- @runO (print [ observe "+1" (+1) x | x <- observe "xs" [1..3]])@--- +-- -- @[2,3,4] -- -- +1 -- { \ 1 -> 2@@ -149,18 +154,18 @@ -- } -- -- xs -- 1 : 2 : 3 : []@--- +-- -- Which says, the return is @[2,3,4]@, there were @3@ calls to +1 -- (showing arguments and results), and @xs@, which was the list -- @1 : 2 : 3 : []@.--- +-- runO :: IO a -> IO () runO program = do { cdss <- debugO program ; let cdss1 = rmEntrySet cdss ; let cdss2 = simplifyCDSSet cdss1- ; let output1 = cdssToOutput cdss2 + ; let output1 = cdssToOutput cdss2 ; let output2 = commonOutput output1 ; let ptyout = pretty 80 (foldr (<>) nil (map renderTop output2)) ; hPutStrLn stderr ""@@ -170,9 +175,9 @@ %************************************************************************-%* *+%* * \subsection{Simulations}-%* *+%* * %************************************************************************ Here we provide stubs for the functionally that is not supported@@ -190,25 +195,25 @@ %************************************************************************-%* *+%* * \subsection{Instances}-%* *+%* * %************************************************************************ The Haskell Base types \begin{code}-instance Observable Int where { observer = observeBase }-instance Observable Bool where { observer = observeBase }-instance Observable Integer where { observer = observeBase }-instance Observable Float where { observer = observeBase }-instance Observable Double where { observer = observeBase }-instance Observable Char where { observer = observeBase }+instance Observable Int where { observer = observeBase }+instance Observable Bool where { observer = observeBase }+instance Observable Integer where { observer = observeBase }+instance Observable Float where { observer = observeBase }+instance Observable Double where { observer = observeBase }+instance Observable Char where { observer = observeBase } -instance Observable () where { observer = observeOpaque "()" }+instance Observable () where { observer = observeOpaque "()" } -- utilities for base types.--- The strictness (by using seq) is the same +-- The strictness (by using seq) is the same -- as the pattern matching done on other constructors. -- we evalute to WHNF, and not further. @@ -228,12 +233,12 @@ instance (Observable a,Observable b,Observable c) => Observable (a,b,c) where observer (a,b,c) = send "," (return (,,) << a << b << c) -instance (Observable a,Observable b,Observable c,Observable d) - => Observable (a,b,c,d) where+instance (Observable a,Observable b,Observable c,Observable d)+ => Observable (a,b,c,d) where observer (a,b,c,d) = send "," (return (,,,) << a << b << c << d) -instance (Observable a,Observable b,Observable c,Observable d,Observable e) - => Observable (a,b,c,d,e) where+instance (Observable a,Observable b,Observable c,Observable d,Observable e)+ => Observable (a,b,c,d,e) where observer (a,b,c,d,e) = send "," (return (,,,,) << a << b << c << d << e) instance (Observable a) => Observable [a] where@@ -253,18 +258,18 @@ \begin{code} instance (Ix a,Observable a,Observable b) => Observable (Array.Array a b) where- observer arr = send "array" (return Array.array << Array.bounds arr - << Array.assocs arr- )+ observer arr = send "array" (return Array.array << Array.bounds arr+ << Array.assocs arr+ ) \end{code} IO monad. \begin{code} instance (Observable a) => Observable (IO a) where- observer fn cxt = - do res <- fn- send "<IO>" (return return << res) cxt+ observer fn cxt =+ do res <- fn+ send "<IO>" (return return << res) cxt \end{code} @@ -273,8 +278,8 @@ \begin{code} instance (Observable a,Observable b) => Observable (a -> b) where observer fn cxt arg = sendObserveFnPacket (- do arg <- thunk arg- thunk (fn arg)) cxt+ do arg <- thunk arg+ thunk (fn arg)) cxt observers = defaultFnObservers \end{code}@@ -293,26 +298,26 @@ %************************************************************************-%* *+%* * \subsection{Classes and Data Definitions}-%* *+%* * %************************************************************************ \begin{code} class Observable a where- {-- - This reveals the name of a specific constructor.- - and gets ready to explain the sub-components.+ {-+ - This reveals the name of a specific constructor.+ - and gets ready to explain the sub-components. - - We put the context second so we can do eta-reduction- - with some of our definitions.- -}- observer :: a -> Parent -> a - {- + - with some of our definitions.+ -}+ observer :: a -> Parent -> a+ {- - This used used to group several observer instances together.- -}- observers :: String -> (Observer -> a) -> a- observers label arg = defaultObservers label arg+ -}+ observers :: String -> (Observer -> a) -> a+ observers label arg = defaultObservers label arg type Observing a = a -> a \end{code}@@ -323,69 +328,76 @@ defaultObservers :: (Observable a) => String -> (Observer -> a) -> a defaultObservers label fn = unsafeWithUniq $ \ node -> do { sendEvent node (Parent 0 0) (Observe label)- ; let observe' sublabel a- = unsafeWithUniq $ \ subnode ->- do { sendEvent subnode (Parent node 0) - (Observe sublabel)- ; return (observer_ a (Parent- { observeParent = subnode- , observePort = 0- }))- }+ ; let observe' sublabel a+ = unsafeWithUniq $ \ subnode ->+ do { sendEvent subnode (Parent node 0)+ (Observe sublabel)+ ; return (observer_ a (Parent+ { observeParent = subnode+ , observePort = 0+ }))+ } ; return (observer_ (fn (O observe'))- (Parent- { observeParent = node- , observePort = 0- }))- }-defaultFnObservers :: (Observable a, Observable b) - => String -> (Observer -> a -> b) -> a -> b+ (Parent+ { observeParent = node+ , observePort = 0+ }))+ }+defaultFnObservers :: (Observable a, Observable b)+ => String -> (Observer -> a -> b) -> a -> b defaultFnObservers label fn arg = unsafeWithUniq $ \ node -> do { sendEvent node (Parent 0 0) (Observe label)- ; let observe' sublabel a- = unsafeWithUniq $ \ subnode ->- do { sendEvent subnode (Parent node 0) - (Observe sublabel)- ; return (observer_ a (Parent- { observeParent = subnode- , observePort = 0- }))- }+ ; let observe' sublabel a+ = unsafeWithUniq $ \ subnode ->+ do { sendEvent subnode (Parent node 0)+ (Observe sublabel)+ ; return (observer_ a (Parent+ { observeParent = subnode+ , observePort = 0+ }))+ } ; return (observer_ (fn (O observe'))- (Parent- { observeParent = node- , observePort = 0- }) arg)- }+ (Parent+ { observeParent = node+ , observePort = 0+ }) arg)+ } \end{code} %************************************************************************-%* *+%* * \subsection{The ObserveM Monad}-%* *+%* * %************************************************************************ -The Observer monad, a simple state monad, +The Observer monad, a simple state monad, for placing numbers on sub-observations. \begin{code} newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) } +instance Functor ObserverM where+ fmap = liftM++instance Applicative ObserverM where+ pure = return+ (<*>) = ap+ instance Monad ObserverM where- return a = ObserverM (\ c i -> (a,i))- fn >>= k = ObserverM (\ c i ->- case runMO fn c i of- (r,i2) -> runMO (k r) c i2- )+ return a = ObserverM (\ c i -> (a,i))+ fn >>= k = ObserverM (\ c i ->+ case runMO fn c i of+ (r,i2) -> runMO (k r) c i2+ ) thunk :: (Observable a) => a -> ObserverM a thunk a = ObserverM $ \ parent port ->- ( observer_ a (Parent- { observeParent = parent- , observePort = port- }) - , port+1 )+ ( observer_ a (Parent+ { observeParent = parent+ , observePort = port+ })+ , port+1 ) (<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') }@@ -393,29 +405,29 @@ %************************************************************************-%* *+%* * \subsection{observe and friends}-%* *+%* * %************************************************************************ Our principle function and class \begin{code} -- | 'observe' observes data structures in flight.--- --- An example of use is +--+-- An example of use is -- @ -- map (+1) . observe \"intermeduate\" . map (+2) -- @ -- -- In this example, we observe the value that flows from the producer -- @map (+2)@ to the consumer @map (+1)@.--- +-- -- 'observe' can also observe functions as well a structural values.--- +-- {-# NOINLINE observe #-} observe :: (Observable a) => String -> a -> a-observe name a = generateContext name a +observe name a = generateContext name a {- This gets called before observer, allowing us to mark - we are entering a, before we do case analysis on@@ -423,15 +435,15 @@ -} {-# NOINLINE observer_ #-}-observer_ :: (Observable a) => a -> Parent -> a +observer_ :: (Observable a) => a -> Parent -> a observer_ a context = sendEnterPacket a context \end{code} \begin{code} data Parent = Parent- { observeParent :: !Int -- my parent- , observePort :: !Int -- my branch number- } deriving Show+ { observeParent :: !Int -- my parent+ , observePort :: !Int -- my branch number+ } deriving Show root = Parent 0 0 \end{code} @@ -440,36 +452,36 @@ \begin{code} unsafeWithUniq :: (Int -> IO a) -> a-unsafeWithUniq fn +unsafeWithUniq fn = unsafePerformIO $ do { node <- getUniq- ; fn node- }+ ; fn node+ } \end{code} \begin{code} generateContext :: (Observable a) => String -> a -> a generateContext label orig = unsafeWithUniq $ \ node -> do { sendEvent node (Parent 0 0) (Observe label)- ; return (observer_ orig (Parent- { observeParent = node- , observePort = 0- })- )- }+ ; return (observer_ orig (Parent+ { observeParent = node+ , observePort = 0+ })+ )+ } send :: String -> ObserverM a -> Parent -> a send consLabel fn context = unsafeWithUniq $ \ node -> do { let (r,portCount) = runMO fn node 0- ; sendEvent node context (Cons portCount consLabel)- ; return r- }+ ; sendEvent node context (Cons portCount consLabel)+ ; return r+ } sendEnterPacket :: (Observable a) => a -> Parent -> a sendEnterPacket r context = unsafeWithUniq $ \ node ->- do { sendEvent node context Enter- ; ourCatchAllIO (evaluate (observer r context))- (handleExc context)- }+ do { sendEvent node context Enter+ ; ourCatchAllIO (evaluate (observer r context))+ (handleExc context)+ } evaluate :: a -> IO a evaluate a = a `seq` return a@@ -477,56 +489,56 @@ sendObserveFnPacket :: ObserverM a -> Parent -> a sendObserveFnPacket fn context = unsafeWithUniq $ \ node ->- do { let (r,_) = runMO fn node 0- ; sendEvent node context Fun- ; return r- }+ do { let (r,_) = runMO fn node 0+ ; sendEvent node context Fun+ ; return r+ } \end{code} %************************************************************************-%* *+%* * \subsection{Event stream}-%* *+%* * %************************************************************************ Trival output functions \begin{code} data Event = Event- { portId :: !Int- , parent :: !Parent- , change :: !Change- }- deriving Show+ { portId :: !Int+ , parent :: !Parent+ , change :: !Change+ }+ deriving Show data Change- = Observe !String- | Cons !Int !String- | Enter- | Fun- deriving Show+ = Observe !String+ | Cons !Int !String+ | Enter+ | Fun+ deriving Show startEventStream :: IO () startEventStream = writeIORef events [] endEventStream :: IO [Event] endEventStream =- do { es <- readIORef events- ; writeIORef events badEvents - ; return es- }+ do { es <- readIORef events+ ; writeIORef events badEvents+ ; return es+ } sendEvent :: Int -> Parent -> Change -> IO () sendEvent nodeId parent change =- do { nodeId `seq` parent `seq` return ()- ; change `seq` return ()- ; takeMVar sendSem- ; es <- readIORef events- ; let event = Event nodeId parent change- ; writeIORef events (event `seq` (event : es))- ; putMVar sendSem ()- }+ do { nodeId `seq` parent `seq` return ()+ ; change `seq` return ()+ ; takeMVar sendSem+ ; es <- readIORef events+ ; let event = Event nodeId parent change+ ; writeIORef events (event `seq` (event : es))+ ; putMVar sendSem ()+ } -- local events :: IORef [Event]@@ -544,9 +556,9 @@ %************************************************************************-%* *+%* * \subsection{unique name supply code}-%* *+%* * %************************************************************************ Use the single threaded version@@ -558,11 +570,11 @@ getUniq :: IO Int getUniq = do { takeMVar uniqSem- ; n <- readIORef uniq- ; writeIORef uniq $! (n + 1)- ; putMVar uniqSem ()- ; return n- }+ ; n <- readIORef uniq+ ; writeIORef uniq $! (n + 1)+ ; putMVar uniqSem ()+ ; return n+ } peepUniq :: IO Int peepUniq = readIORef uniq@@ -580,39 +592,39 @@ %************************************************************************-%* *+%* * \subsection{Global, initualizers, etc}-%* *+%* * %************************************************************************ \begin{code} openObserveGlobal :: IO () openObserveGlobal = do { initUniq- ; startEventStream- }+ ; startEventStream+ } closeObserveGlobal :: IO [Event] closeObserveGlobal = do { evs <- endEventStream ; putStrLn ""- ; return evs- }+ ; return evs+ } \end{code} %************************************************************************-%* *+%* * \subsection{The CDS and converting functions}-%* *+%* * %************************************************************************ \begin{code} data CDS = CDSNamed String CDSSet- | CDSCons Int String [CDSSet]- | CDSFun Int CDSSet CDSSet- | CDSEntered Int- deriving (Show,Eq,Ord)+ | CDSCons Int String [CDSSet]+ | CDSFun Int CDSSet CDSSet+ | CDSEntered Int+ deriving (Show,Eq,Ord) type CDSSet = [CDS] @@ -626,54 +638,54 @@ mid_arr :: Array Int [(Int,CDS)] mid_arr = accumArray (flip (:)) [] bnds- [ (pnode,(pport,res node))- | (Event node (Parent pnode pport) _) <- pairs- ]+ [ (pnode,(pport,res node))+ | (Event node (Parent pnode pport) _) <- pairs+ ] - out_arr = array bnds -- never uses 0 index- [ (node,getNode'' node change)- | (Event node _ change) <- pairs- ]+ out_arr = array bnds -- never uses 0 index+ [ (node,getNode'' node change)+ | (Event node _ change) <- pairs+ ] getNode'' :: Int -> Change -> CDS getNode'' node change = case change of- (Observe str) -> CDSNamed str (getChild node 0)- (Enter) -> CDSEntered node- (Fun) -> CDSFun node (getChild node 0) (getChild node 1)- (Cons portc cons)- -> CDSCons node cons - [ getChild node n | n <- [0..(portc-1)]]+ (Observe str) -> CDSNamed str (getChild node 0)+ (Enter) -> CDSEntered node+ (Fun) -> CDSFun node (getChild node 0) (getChild node 1)+ (Cons portc cons)+ -> CDSCons node cons+ [ getChild node n | n <- [0..(portc-1)]] getChild :: Int -> Int -> CDSSet getChild pnode pport =- [ content+ [ content | (pport',content) <- (!) mid_arr pnode- , pport == pport'- ]+ , pport == pport'+ ] render :: Int -> Bool -> CDS -> DOC render prec par (CDSCons _ ":" [cds1,cds2]) =- if (par && not needParen) - then doc -- dont use paren (..) because we dont want a grp here!- else paren needParen doc+ if (par && not needParen)+ then doc -- dont use paren (..) because we dont want a grp here!+ else paren needParen doc where- doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>- renderSet' 4 True cds2- needParen = prec > 4+ doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>+ renderSet' 4 True cds2+ needParen = prec > 4 render prec par (CDSCons _ "," cdss) | length cdss > 0 =- nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)- (map renderSet cdss) <>- text ")")+ nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)+ (map renderSet cdss) <>+ text ")") render prec par (CDSCons _ name cdss) =- paren (length cdss > 0 && prec /= 0)- (nest 2- (text name <> foldr (<>) nil- [ sep <> renderSet' 10 False cds- | cds <- cdss - ]- )- )+ paren (length cdss > 0 && prec /= 0)+ (nest 2+ (text name <> foldr (<>) nil+ [ sep <> renderSet' 10 False cds+ | cds <- cdss+ ]+ )+ ) {- renderSet handles the various styles of CDSSet. -}@@ -684,28 +696,28 @@ renderSet' :: Int -> Bool -> CDSSet -> DOC renderSet' _ _ [] = text "_" renderSet' prec par [cons@(CDSCons {})] = render prec par cons-renderSet' prec par cdss = - nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>- text ", " <> b)- (map renderFn pairs) <>- line <> text "}")+renderSet' prec par cdss =+ nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>+ text ", " <> b)+ (map renderFn pairs) <>+ line <> text "}") where- pairs = nub (sort (findFn cdss))- -- local nub for sorted lists- nub [] = []- nub (a:a':as) | a == a' = nub (a' : as)+ pairs = nub (sort (findFn cdss))+ -- local nub for sorted lists+ nub [] = []+ nub (a:a':as) | a == a' = nub (a' : as) nub (a:as) = a : nub as renderFn :: ([CDSSet],CDSSet) -> DOC-renderFn (args,res) - = grp (nest 3 - (text "\\ " <>- foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)- nil- args <> sep <>- text "-> " <> renderSet' 0 False res- )+renderFn (args,res)+ = grp (nest 3+ (text "\\ " <>+ foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)+ nil+ args <> sep <>+ text "-> " <> renderSet' 0 False res+ ) ) findFn :: CDSSet -> [([CDSSet],CDSSet)]@@ -722,9 +734,9 @@ renderTop :: Output -> DOC renderTop (OutLabel str set extras) =- nest 2 (text ("-- " ++ str) <> line <>- renderSet set- <> renderTops extras) <> line+ nest 2 (text ("-- " ++ str) <> line <>+ renderSet set+ <> renderTops extras) <> line rmEntry :: CDS -> CDS rmEntry (CDSNamed str set) = CDSNamed str (rmEntrySet set)@@ -734,38 +746,38 @@ rmEntrySet = map rmEntry . filter noEntered where- noEntered (CDSEntered _) = False- noEntered _ = True+ noEntered (CDSEntered _) = False+ noEntered _ = True simplifyCDS :: CDS -> CDS simplifyCDS (CDSNamed str set) = CDSNamed str (simplifyCDSSet set)-simplifyCDS (CDSCons _ "throw" - [[CDSCons _ "ErrorCall" set]]- ) = simplifyCDS (CDSCons 0 "error" set)-simplifyCDS cons@(CDSCons i str sets) = - case spotString [cons] of- Just str | not (null str) -> CDSCons 0 (show str) []- _ -> CDSCons 0 str (map simplifyCDSSet sets)+simplifyCDS (CDSCons _ "throw"+ [[CDSCons _ "ErrorCall" set]]+ ) = simplifyCDS (CDSCons 0 "error" set)+simplifyCDS cons@(CDSCons i str sets) =+ case spotString [cons] of+ Just str | not (null str) -> CDSCons 0 (show str) []+ _ -> CDSCons 0 str (map simplifyCDSSet sets) simplifyCDS (CDSFun i a b) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b)- -- replace with - -- CDSCons i "->" [simplifyCDSSet a,simplifyCDSSet b]- -- for turning off the function stuff.+ -- replace with+ -- CDSCons i "->" [simplifyCDSSet a,simplifyCDSSet b]+ -- for turning off the function stuff. -simplifyCDSSet = map simplifyCDS +simplifyCDSSet = map simplifyCDS spotString :: CDSSet -> Maybe String spotString [CDSCons _ ":"- [[CDSCons _ str []]- ,rest- ]- ] - = do { ch <- case reads str of- [(ch,"")] -> return ch+ [[CDSCons _ str []]+ ,rest+ ]+ ]+ = do { ch <- case reads str of+ [(ch,"")] -> return ch _ -> Nothing- ; more <- spotString rest- ; return (ch : more)- }+ ; more <- spotString rest+ ; return (ch : more)+ } spotString [CDSCons _ "[]" []] = return [] spotString other = Nothing @@ -778,7 +790,7 @@ data Output = OutLabel String CDSSet [Output] | OutData CDS- deriving (Eq,Ord)+ deriving (Eq,Ord) commonOutput :: [Output] -> [Output]@@ -790,7 +802,7 @@ cdssToOutput = map cdsToOutput cdsToOutput (CDSNamed name cdsset)- = OutLabel name res1 res2+ = OutLabel name res1 res2 where res1 = [ cdss | (OutData cdss) <- res ] res2 = [ out | out@(OutLabel {}) <- res ]@@ -802,95 +814,95 @@ %************************************************************************-%* *+%* * \subsection{A Pretty Printer}-%* *+%* * %************************************************************************ This pretty printer is based on Wadler's pretty printer. \begin{code}-data DOC = NIL -- nil - | DOC :<> DOC -- beside - | NEST Int DOC- | TEXT String- | LINE -- always "\n"- | SEP -- " " or "\n"- | BREAK -- "" or "\n"- | DOC :<|> DOC -- choose one- deriving (Eq,Show)-data Doc = Nil- | Text Int String Doc- | Line Int Int Doc- deriving (Show,Eq)+data DOC = NIL -- nil+ | DOC :<> DOC -- beside+ | NEST Int DOC+ | TEXT String+ | LINE -- always "\n"+ | SEP -- " " or "\n"+ | BREAK -- "" or "\n"+ | DOC :<|> DOC -- choose one+ deriving (Eq,Show)+data Doc = Nil+ | Text Int String Doc+ | Line Int Int Doc+ deriving (Show,Eq) -mkText :: String -> Doc -> Doc-mkText s d = Text (toplen d + length s) s d+mkText :: String -> Doc -> Doc+mkText s d = Text (toplen d + length s) s d -mkLine :: Int -> Doc -> Doc-mkLine i d = Line (toplen d + i) i d+mkLine :: Int -> Doc -> Doc+mkLine i d = Line (toplen d + i) i d -toplen :: Doc -> Int-toplen Nil = 0-toplen (Text w s x) = w-toplen (Line w s x) = 0+toplen :: Doc -> Int+toplen Nil = 0+toplen (Text w s x) = w+toplen (Line w s x) = 0 -nil = NIL-x <> y = x :<> y-nest i x = NEST i x-text s = TEXT s-line = LINE-sep = SEP-brk = BREAK+nil = NIL+x <> y = x :<> y+nest i x = NEST i x+text s = TEXT s+line = LINE+sep = SEP+brk = BREAK -fold x = grp (brk <> x)+fold x = grp (brk <> x) -grp :: DOC -> DOC-grp x = - case flatten x of- Just x' -> x' :<|> x- Nothing -> x+grp :: DOC -> DOC+grp x =+ case flatten x of+ Just x' -> x' :<|> x+ Nothing -> x -flatten :: DOC -> Maybe DOC-flatten NIL = return NIL-flatten (x :<> y) = - do x' <- flatten x- y' <- flatten y- return (x' :<> y')-flatten (NEST i x) = - do x' <- flatten x- return (NEST i x')-flatten (TEXT s) = return (TEXT s)-flatten LINE = Nothing -- abort-flatten SEP = return (TEXT " ") -- SEP is space-flatten BREAK = return NIL -- BREAK is nil-flatten (x :<|> y) = flatten x+flatten :: DOC -> Maybe DOC+flatten NIL = return NIL+flatten (x :<> y) =+ do x' <- flatten x+ y' <- flatten y+ return (x' :<> y')+flatten (NEST i x) =+ do x' <- flatten x+ return (NEST i x')+flatten (TEXT s) = return (TEXT s)+flatten LINE = Nothing -- abort+flatten SEP = return (TEXT " ") -- SEP is space+flatten BREAK = return NIL -- BREAK is nil+flatten (x :<|> y) = flatten x -layout :: Doc -> String-layout Nil = ""-layout (Text _ s x) = s ++ layout x-layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x+layout :: Doc -> String+layout Nil = ""+layout (Text _ s x) = s ++ layout x+layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x best w k doc = be w k [(0,doc)] -be :: Int -> Int -> [(Int,DOC)] -> Doc-be w k [] = Nil-be w k ((i,NIL):z) = be w k z-be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z)+be :: Int -> Int -> [(Int,DOC)] -> Doc+be w k [] = Nil+be w k ((i,NIL):z) = be w k z+be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z) be w k ((i,NEST j x):z) = be w k ((k+j,x):z)-be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z-be w k ((i,LINE):z) = i `mkLine` be w i z-be w k ((i,SEP):z) = i `mkLine` be w i z-be w k ((i,BREAK):z) = i `mkLine` be w i z-be w k ((i,x :<|> y):z) = better w k - (be w k ((i,x):z))- (be w k ((i,y):z))+be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z+be w k ((i,LINE):z) = i `mkLine` be w i z+be w k ((i,SEP):z) = i `mkLine` be w i z+be w k ((i,BREAK):z) = i `mkLine` be w i z+be w k ((i,x :<|> y):z) = better w k+ (be w k ((i,x):z))+ (be w k ((i,y):z)) -better :: Int -> Int -> Doc -> Doc -> Doc-better w k x y = if (w-k) >= toplen x then x else y+better :: Int -> Int -> Doc -> Doc -> Doc+better w k x y = if (w-k) >= toplen x then x else y -pretty :: Int -> DOC -> String-pretty w x = layout (best w 0 x)+pretty :: Int -> DOC -> String+pretty w x = layout (best w 0 x) \end{code}
LICENSE view
@@ -1,5 +1,5 @@ The Haskell Object Observation Debugging toolkit (HOOD) is Copyright-(c) Andy Gill, 2000, (c) The University of Kansas, 2010.+(c) Andy Gill, 2000, (c) The University of Kansas, 2010-2015. All rights reserved, and is distributed as free software under the following license.
+ README.md view
@@ -0,0 +1,3 @@+# `hood` [](http://hackage.haskell.org/package/hood) [](https://travis-ci.org/ku-fpg/hood)++Hood debugger, based on the idea of observing functions and structures as they are evaluated.
hood.cabal view
@@ -1,5 +1,5 @@ Name: hood-Version: 0.2+Version: 0.2.1 Synopsis: Debugging by observing in place Description: Hood debugger, based on the idea of observing functions and structures as they are evaluated. Category: Debug, Trace@@ -7,13 +7,19 @@ License-file: LICENSE Author: Andy Gill Maintainer: Andy Gill <andygill@ku.edu>-Copyright: (c) 2000 Andy Gill, (c) 2010 University of Kansas+Copyright: (c) 2000 Andy Gill, (c) 2010-2015 University of Kansas Homepage: http://www.ittc.ku.edu/csdl/fpg/Hood-Stability: alpha-build-type: Simple+bug-reports: https://github.com/ku-fpg/hood/issues+Stability: alpha+build-type: Simple Cabal-Version: >= 1.6+extra-source-files: CHANGELOG.md, README.md Library Build-Depends: base >= 4 && < 5, array Exposed-modules: Debug.Hood.Observe++source-repository head+ type: git+ location: https://github.com/ku-fpg/hood