diff --git a/GHood.cabal b/GHood.cabal --- a/GHood.cabal +++ b/GHood.cabal @@ -1,5 +1,5 @@ Name: GHood -Version: 0.0.2 +Version: 0.0.3 License: BSD3 License-file: LICENSE Copyright: diff --git a/src/Debug/Observe.hs b/src/Debug/Observe.hs --- a/src/Debug/Observe.hs +++ b/src/Debug/Observe.hs @@ -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" })