diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +## 0.2.1 +* Fixed build with GHC 7.10 diff --git a/Debug/Hood/Observe.lhs b/Debug/Hood/Observe.lhs --- a/Debug/Hood/Observe.lhs +++ b/Debug/Hood/Observe.lhs @@ -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 "" (return return << res) cxt + observer fn cxt = + do res <- fn + send "" (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} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# `hood` [![Hackage version](https://img.shields.io/hackage/v/hood.svg?style=flat)](http://hackage.haskell.org/package/hood) [![Build Status](https://img.shields.io/travis/ku-fpg/hood.svg?style=flat)](https://travis-ci.org/ku-fpg/hood) + +Hood debugger, based on the idea of observing functions and structures as they are evaluated. diff --git a/hood.cabal b/hood.cabal --- a/hood.cabal +++ b/hood.cabal @@ -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 -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