GHood 0.0.2 → 0.0.3

raw patch · 2 files changed

+48/−42 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• GHood.cabal +1/−1
• src/Debug/Observe.hs +47/−41

@@ -1,5 +1,5 @@ Name:            GHood-Version:         0.0.2+Version:         0.0.3 License:         BSD3 License-file:    LICENSE Copyright:

@@ -107,11 +107,11 @@  -- | Runs and prints observe ridden code. printO :: (Show a) => a -> IO ()-printO expr = runO (print expr)+printO = runO . print  -- | Prints a string during observation. putStrO :: String -> IO ()-putStrO expr = runO (putStr expr)+putStrO = runO . putStr  -- | Runs observe ridden code. runO :: IO a -> IO ()@@ -152,13 +152,13 @@  -- | Observe a base type observeBase :: (Show a) => a -> Parent -> a-observeBase lit cxt = seq lit $ send (show lit) (return lit) cxt+observeBase lit = seq lit . send (show lit) (return lit) -- ^ The strictness (by using seq) is the same as the pattern matching done on other constructors. -- We evaluate to WHNF, and not further.  -- | Observe a base type as an 'opaque' string. observeOpaque :: String -> a -> Parent -> a-observeOpaque str val cxt = seq val $ send str (return val) cxt+observeOpaque str val = seq val . send str (return val)  -- The Constructors. @@ -233,7 +233,7 @@     This used used to group several observer instances together. 	 -} 	observers :: String -> (Observer -> a) -> a-	observers label arg = defaultObservers label arg+	observers = defaultObservers  type Observing a = a -> a @@ -247,35 +247,34 @@ 	       = unsafeWithUniq $ \ subnode -> 		 do { sendEvent subnode (Parent node 0)  		                        (Observe sublabel)-		    ; return (observer_ a (Parent+		    ; return (observer_ a Parent 			{ observeParent = subnode 			, observePort   = 0-		        }))+		        }) 		    }         ; return (observer_ (fn (O observe'))-		       (Parent+		       Parent 			{ observeParent = node 			, observePort   = 0-		        }))+		        }) 	}-defaultFnObservers :: (Observable a,Observable b) -		      => String -> (Observer -> a -> b) -> a -> b+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+		    ; return (observer_ a Parent 			{ observeParent = subnode 			, observePort   = 0-		        }))+		        }) 		    }         ; return (observer_ (fn (O observe'))-		       (Parent+		       Parent 			{ observeParent = node 			, observePort   = 0-		        }) arg)+		        } arg) 	} 	 -- * The ObserveM Monad@@ -293,10 +292,10 @@ -- | thunk is for marking suspensions. thunk :: (Observable a) => a -> ObserverM a thunk a = ObserverM $ \ parent port ->-		( observer_ a (Parent+		( observer_ a Parent 				{ observeParent = parent 				, observePort   = port-				}) +				} 		, port+1 )  -- | the infix (<<) is a shortcut for constructor arguments.@@ -308,7 +307,7 @@ {-# NOINLINE observe #-} -- | Our principle function and class observe :: (Observable a) => String -> a -> a-observe name a = generateContext name a +observe = generateContext   {-# NOINLINE observer_ #-} {-|@@ -317,7 +316,7 @@  our object.  -} observer_ :: (Observable a) => a -> Parent -> a -observer_ a context = sendEnterPacket a context+observer_ = sendEnterPacket  -- | Parent book-keeping information. data Parent = Parent@@ -337,10 +336,10 @@ generateContext :: (Observable a) => String -> a -> a generateContext label orig = unsafeWithUniq $ \ node ->      do { sendEvent node (Parent 0 0) (Observe label)-	; return (observer_ orig (Parent+	; return (observer_ orig Parent 			{ observeParent = node 			, observePort   = 0-		        })+		        } 		  ) 	} @@ -429,7 +428,12 @@ -- Use the single threaded version  initUniq :: IO ()-initUniq = writeIORef uniq 1+initUniq = do+	u <- readIORef uniq+	when (u/=1) $ hPutStrLn stderr +		"Warning[Debug.Observe]: reinitializing event counter (may lead to invalid event log\n\+		\  if 'runO'/'printO' encounters already partially observed structures)"+	writeIORef uniq 1  getUniq :: IO Int getUniq@@ -452,7 +456,7 @@ uniqSem :: MVar () uniqSem = unsafePerformIO $ newMVar () --- * Global, initualizers, etc+-- * Global, initializers, etc  openObserveGlobal :: IO () openObserveGlobal =@@ -481,7 +485,7 @@ eventsToCDS :: [Event] -> CDSSet eventsToCDS pairs = getChild 0 0    where-     res i = (!) out_arr i+     res = (!) out_arr       bnds = (0, length pairs) @@ -515,7 +519,7 @@  render  :: Int -> Bool -> CDS -> DOC render prec par (CDSCons _ ":" [cds1,cds2]) =-	if (par && not needParen)  +	if par && not needParen 	then doc -- dont use paren (..) because we dont want a grp here! 	else paren needParen doc    where@@ -690,13 +694,13 @@ 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	 = NEST+text	 = TEXT+line	 = LINE+sep	 = SEP+brk	 = BREAK  fold x			= grp (brk <> x) @@ -744,8 +748,8 @@ 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	= layout . best w 0  -- * GHood connection @@ -754,7 +758,9 @@ observeEventsLog = "ObserveEvents.log" call_GHood       = do    ghood <- getDataFileName "GHood.jar"-   system $ "java -cp " ++ ghood ++ " GHood " ++ observeEventsLog+   let call = "java -cp \"" ++ ghood ++ "\" GHood " ++ observeEventsLog+   hPutStrLn stderr call   +   system call  eventHook e   = return () -- currently not used eventsHook es = @@ -764,12 +770,12 @@     disconnectBrowser  toBrowser e = -       (show (portId e))-       ++" "++(show (observeParent (parent e)))-       ++" "++(show (observePort (parent e)))-       ++" "++(case change e of-              { Observe s -> "Observe |"++s-              ; Cons n  s -> "Cons "++(show n)++" |"++s+       show (portId e)+       ++ " " ++ show (observeParent (parent e))+       ++ " " ++ show (observePort (parent e))+       ++ " " ++ (case change e of+              { Observe s -> "Observe |" ++ s+              ; Cons n  s -> "Cons " ++ show n ++ " |" ++ s               ; Enter     -> "Enter"               ; Fun       -> "Fun"               })