hood 0.3 → 0.3.1

raw patch · 4 files changed

+79/−38 lines, 4 filesdep +hooddep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hood

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• Debug/Hood/Observe.hs +39/−36
• hood.cabal +11/−2
• test/test.hs +26/−0

@@ -1,3 +1,6 @@+## 0.3.1 [2018.01.18]+* Fix the build on GHC 8.4.+ ## 0.3 * `Observable` instances can be derived for `Generic` instances using   `DefaultSignatures` ([MaartenFaddegon](https://github.com/ku-fpg/hood/pull/1))

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -61,6 +62,7 @@    , debugO         -- IO a -> IO [CDS]   , CDS(..)+  , CDSSet   ) where  {-@@ -97,7 +99,11 @@ -} import Data.Dynamic ( Dynamic ) -import Prelude+import Prelude hiding (+#if MIN_VERSION_base(4,11,0)+                        (<>)+#endif+                      )  infixl 9 << @@ -162,7 +168,7 @@        ; let cdss2 = simplifyCDSSet cdss1        ; let output1 = cdssToOutput cdss2        ; let output2 = commonOutput output1-       ; let ptyout  = pretty 80 (foldr (<>) nil (map renderTop output2))+       ; let ptyout  = pretty 80 $ foldr ((<>) . renderTop) nil output2        ; hPutStrLn stderr ""        ; hPutStrLn stderr ptyout        }@@ -308,7 +314,7 @@          - This used used to group several observer instances together.          -}         observers :: String -> (Observer -> a) -> a-        observers label arg = defaultObservers label arg+        observers = defaultObservers  class GObservable f where         gdmobserver :: f a -> Parent -> f a@@ -354,7 +360,7 @@  -- Products: encode multiple arguments to constructors instance (GObservable a, GObservable b) => GObservable (a :*: b) where-        gdmobserver (a :*: b) cxt = (gdmobserver a cxt) :*: (gdmobserver b cxt)+        gdmobserver (a :*: b) cxt = gdmobserver a cxt :*: gdmobserver b cxt         gdmObserveChildren (a :*: b) = do a'  <- gdmObserveChildren a                                           b'  <- gdmObserveChildren b                                           return (a' :*: b')@@ -368,14 +374,14 @@  gthunk :: (GObservable f) => f a -> ObserverM (f a) gthunk a = ObserverM $ \ parent port ->-                ( gdmobserver_ a (Parent+                ( gdmobserver_ a Parent                                 { observeParent = parent                                 , observePort   = port-                                })+                                }                 , port+1 )  gdmobserver_ :: (GObservable f) => f a -> Parent -> f a-gdmobserver_ a context = gsendEnterPacket a context+gdmobserver_ = gsendEnterPacket  gsendEnterPacket :: (GObservable f) => f a -> Parent -> f a gsendEnterPacket r context = unsafeWithUniq $ \ node ->@@ -395,16 +401,16 @@                = 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@@ -414,16 +420,16 @@                = 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)         }  {-@@ -455,10 +461,10 @@  thunk :: (Observable a) => a -> ObserverM a thunk a = ObserverM $ \ parent port ->-                ( observer_ a (Parent+                ( observer_ a Parent                                 { observeParent = parent                                 , observePort   = port-                                })+                                }                 , port+1 )  (<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b@@ -488,7 +494,7 @@ -- {-# NOINLINE observe #-} observe :: (Observable a) => String -> a -> a-observe name a = generateContext name a+observe = generateContext  {- This gets called before observer, allowing us to mark  - we are entering a, before we do case analysis on@@ -497,7 +503,7 @@  {-# NOINLINE observer_ #-} observer_ :: (Observable a) => a -> Parent -> a-observer_ a context = sendEnterPacket a context+observer_ = sendEnterPacket  data Parent = Parent         { observeParent :: !Int -- my parent@@ -510,17 +516,19 @@  unsafeWithUniq :: (Int -> IO a) -> a unsafeWithUniq fn-  = unsafePerformIO $ do { node <- getUniq-                         ; fn node+  = unsafePerformIO $ do { node <- readUniq+                         ; r <- fn node+                         ; incrementUniq node+                         ; return r                          }  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-                        })+                        }                   )         } @@ -595,6 +603,7 @@            }  -- local+{-# NOINLINE events #-} events :: IORef [Event] events = unsafePerformIO $ newIORef badEvents @@ -620,17 +629,11 @@ initUniq :: IO () initUniq = writeIORef uniq 1 -getUniq :: IO Int-getUniq-    = do { takeMVar uniqSem-         ; n <- readIORef uniq-         ; writeIORef uniq $! (n + 1)-         ; putMVar uniqSem ()-         ; return n-         }+incrementUniq :: Int -> IO ()+incrementUniq n = writeIORef uniq $! (n + 1) -peepUniq :: IO Int-peepUniq = readIORef uniq+readUniq :: IO Int+readUniq = readIORef uniq  -- locals {-# NOINLINE uniq #-}@@ -682,7 +685,7 @@ eventsToCDS :: [Event] -> CDSSet eventsToCDS pairs = getChild 0 0    where-     res i = (!) out_arr i+     res = (!) out_arr       bnds = (0, length pairs) @@ -716,7 +719,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@@ -780,7 +783,7 @@ findFn' other rest = ([],[other]) : rest  renderTops []   = nil-renderTops tops = line <> foldr (<>) nil (map renderTop tops)+renderTops tops = line <> foldr ((<>) . renderTop ) nil tops  renderTop :: Output -> Doc renderTop (OutLabel str set extras) =

@@ -1,5 +1,5 @@ Name:                hood-Version:             0.3+Version:             0.3.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@@ -8,7 +8,7 @@ Author:              Andy Gill Maintainer:          Andy Gill <andygill@ku.edu> Copyright:           (c) 2000 Andy Gill, (c) 2010-2015 University of Kansas, (c) 2013-2015 Maarten Faddegon-Homepage:            http://www.ittc.ku.edu/csdl/fpg/Hood+Homepage:            http://ku-fpg.github.io/software/hood bug-reports:         https://github.com/ku-fpg/hood/issues Stability:           alpha build-type:          Simple@@ -17,12 +17,21 @@                    , GHC == 7.6.3                    , GHC == 7.8.4                    , GHC == 7.10.3+                   , GHC == 8.0.2+                   , GHC == 8.2.2+                   , GHC == 8.4.1 extra-source-files:  CHANGELOG.md, README.md  Library   Build-Depends: base >= 4.5 && < 5, array, FPretty, ghc-prim   Exposed-modules:       Debug.Hood.Observe++Test-Suite hood-test+  Type:                exitcode-stdio-1.0+  Hs-Source-Dirs:      test+  Main-Is:             test.hs+  Build-Depends:       base, ghc-prim, hood  source-repository head     type:     git

@@ -0,0 +1,26 @@+#!/usr/bin/env stack+{-# LANGUAGE DeriveGeneric #-}+-- stack --resolver lts-8.4 runghc --package hood+-- Minimum program to reproduce https://github.com/ku-fpg/hood/issues/5++import           Debug.Hood.Observe+import           GHC.Generics+++data Hoge =+  Hoge+    { hoge1 :: Int+    , hoge2 :: String+    } deriving Generic++instance Observable Hoge+++main :: IO ()+main = runO $ print $ f undefined+++f :: Hoge -> Bool+f = observe "f" f'+f' :: Hoge -> Bool+f' h@(Hoge _h1 _h2) = error "ERROR"