├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── Debug └── Hood │ └── Observe.hs ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── hood.cabal └── test └── test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--no-no-tests-no-bench' '--no-installed' 'cabal.project' 4 | # 5 | # For more information, see https://github.com/hvr/multi-ghc-travis 6 | # 7 | language: c 8 | sudo: false 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | - rm -rfv $HOME/.cabal/packages/head.hackage 28 | 29 | matrix: 30 | include: 31 | - compiler: "ghc-8.4.3" 32 | env: GHCHEAD=true 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}} 34 | - compiler: "ghc-8.2.2" 35 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}} 37 | - compiler: "ghc-8.0.2" 38 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 39 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}} 40 | - compiler: "ghc-7.10.3" 41 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 42 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}} 43 | - compiler: "ghc-7.8.4" 44 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 45 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}} 46 | - compiler: "ghc-7.6.3" 47 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 48 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.6.3], sources: [hvr-ghc]}} 49 | - compiler: "ghc-7.4.2" 50 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 51 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.4.2], sources: [hvr-ghc]}} 52 | - compiler: "ghc-head" 53 | env: GHCHEAD=true 54 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} 55 | 56 | allow_failures: 57 | - compiler: "ghc-8.4.3" 58 | - compiler: "ghc-head" 59 | 60 | before_install: 61 | - HC=${CC} 62 | - HCPKG=${HC/ghc/ghc-pkg} 63 | - unset CC 64 | - ROOTDIR=$(pwd) 65 | - mkdir -p $HOME/.local/bin 66 | - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 67 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 68 | - echo $HCNUMVER 69 | 70 | install: 71 | - cabal --version 72 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 73 | - BENCH=${BENCH---enable-benchmarks} 74 | - TEST=${TEST---enable-tests} 75 | - HADDOCK=${HADDOCK-true} 76 | - INSTALLED=${INSTALLED-true} 77 | - GHCHEAD=${GHCHEAD-false} 78 | - travis_retry cabal update -v 79 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 80 | - rm -fv cabal.project cabal.project.local 81 | # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage 82 | - | 83 | if $GHCHEAD; then 84 | sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config 85 | 86 | echo 'repository head.hackage' >> ${HOME}/.cabal/config 87 | echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config 88 | echo ' secure: True' >> ${HOME}/.cabal/config 89 | echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config 90 | echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config 91 | echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config 92 | echo ' key-threshold: 3' >> ${HOME}/.cabal.config 93 | 94 | cabal new-update head.hackage -v 95 | fi 96 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 97 | - "printf 'packages: \".\"\\n' > cabal.project" 98 | - cat cabal.project 99 | - if [ -f "./configure.ac" ]; then 100 | (cd "." && autoreconf -i); 101 | fi 102 | - rm -f cabal.project.freeze 103 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 104 | - rm -rf .ghc.environment.* "."/dist 105 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 106 | 107 | # Here starts the actual work to be performed for the package under test; 108 | # any command which exits with a non-zero exit code causes the build to fail. 109 | script: 110 | # test that source-distributions can be generated 111 | - (cd "." && cabal sdist) 112 | - mv "."/dist/hood-*.tar.gz ${DISTDIR}/ 113 | - cd ${DISTDIR} || false 114 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 115 | - "printf 'packages: hood-*/*.cabal\\n' > cabal.project" 116 | - cat cabal.project 117 | 118 | 119 | # build & run tests, build benchmarks 120 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 121 | - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi 122 | 123 | # cabal check 124 | - (cd hood-* && cabal check) 125 | 126 | # haddock 127 | - rm -rf ./dist-newstyle 128 | - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi 129 | 130 | # REGENDATA ["-o",".travis.yml","--ghc-head","--no-no-tests-no-bench","--no-installed","cabal.project"] 131 | # EOF 132 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.3.1 [2018.01.18] 2 | * Fix the build on GHC 8.4. 3 | 4 | ## 0.3 5 | * `Observable` instances can be derived for `Generic` instances using 6 | `DefaultSignatures` ([MaartenFaddegon](https://github.com/ku-fpg/hood/pull/1)) 7 | * Depend on the `FPretty` library for pretty-printing, which requires 8 | `base-4.5` or greater. 9 | 10 | ## 0.2.1 11 | * Fixed build with GHC 7.10 12 | -------------------------------------------------------------------------------- /Debug/Hood/Observe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | {- 9 | The file is part of the Haskell Object Observation Debugger, 10 | (HOOD) March 2010 release. 11 | 12 | HOOD is a small post-mortem debugger for the lazy functional 13 | language Haskell. It is based on the concept of observation of 14 | intermediate data structures, rather than the more traditional 15 | stepping and variable examination paradigm used by imperative 16 | language debuggers. 17 | 18 | Copyright (c) Andy Gill, 1992-2000 19 | Copyright (c) The University of Kansas 2010 20 | Copyright (c) Maarten Faddegon, 2013-2015 21 | 22 | All rights reserved. HOOD is distributed as free software under 23 | the license in the file "License", which available from the HOOD 24 | web page, 25 | 26 | This module produces CDS's, based on the observation made on Haskell 27 | objects, including base types, constructors and functions. 28 | 29 | WARNING: unrestricted use of 'unsafePerformIO' below. 30 | 31 | This was ported for the version found on . 32 | -} 33 | module Debug.Hood.Observe 34 | 35 | {- 36 | ************************************************************************ 37 | * * 38 | Exports 39 | * * 40 | ************************************************************************ 41 | -} 42 | ( 43 | -- * The main Hood API 44 | 45 | 46 | observe -- (Observable a) => String -> a -> a 47 | , Observer(..) -- contains a 'forall' typed observe (if supported). 48 | , Observing -- a -> a 49 | , Observable(..) -- Class 50 | , runO -- IO a -> IO () 51 | , printO -- a -> IO () 52 | , putStrO -- String -> IO () 53 | 54 | -- * For advanced users, that want to render their own datatypes. 55 | , (<<) -- (Observable a) => ObserverM (a -> b) -> a -> ObserverM b 56 | , thunk -- (Observable a) => a -> ObserverM a 57 | , send 58 | , observeBase 59 | , observeOpaque 60 | 61 | -- * For users that want to write there own render drivers. 62 | 63 | , debugO -- IO a -> IO [CDS] 64 | , CDS(..) 65 | , CDSSet 66 | ) where 67 | 68 | {- 69 | ************************************************************************ 70 | * * 71 | Imports and infixing 72 | * * 73 | ************************************************************************ 74 | -} 75 | import System.IO 76 | import Data.Maybe 77 | import Control.Applicative 78 | import Control.Monad 79 | import Data.Array as Array 80 | import Data.List 81 | --import System 82 | 83 | -- The only non standard one we assume 84 | --import IOExts 85 | import Data.IORef 86 | import System.IO.Unsafe 87 | import GHC.Generics 88 | import Text.PrettyPrint.FPretty hiding ((<$>)) 89 | 90 | import Control.Concurrent 91 | 92 | import Control.Exception ( Exception, throw ) 93 | import qualified Control.Exception as Exception 94 | {- 95 | ( catch 96 | , Exception(..) 97 | , throw 98 | ) as Exception 99 | -} 100 | import Data.Dynamic ( Dynamic ) 101 | 102 | import Prelude hiding ( 103 | #if MIN_VERSION_base(4,11,0) 104 | (<>) 105 | #endif 106 | ) 107 | 108 | infixl 9 << 109 | 110 | {- 111 | ************************************************************************ 112 | * * 113 | External start functions 114 | * * 115 | ************************************************************************ 116 | 117 | Run the observe ridden code. 118 | -} 119 | 120 | -- | run some code and return the CDS structure (for when you want to write your own debugger). 121 | debugO :: IO a -> IO [CDS] 122 | debugO program = 123 | do { initUniq 124 | ; startEventStream 125 | ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]" 126 | ; ourCatchAllIO (do { program ; return () }) 127 | (hPutStrLn stderr . errorMsg) 128 | ; events <- endEventStream 129 | ; return (eventsToCDS events) 130 | } 131 | 132 | -- | print a value, with debugging 133 | printO :: (Show a) => a -> IO () 134 | printO expr = runO (print expr) 135 | 136 | -- | print a string, with debugging 137 | putStrO :: String -> IO () 138 | putStrO expr = runO (putStr expr) 139 | 140 | -- | The main entry point; run some IO code, and debug inside it. 141 | -- 142 | -- An example of using this debugger is 143 | -- 144 | -- @runO (print [ observe "+1" (+1) x | x <- observe "xs" [1..3]])@ 145 | -- 146 | -- @[2,3,4] 147 | -- -- +1 148 | -- { \ 1 -> 2 149 | -- } 150 | -- -- +1 151 | -- { \ 2 -> 3 152 | -- } 153 | -- -- +1 154 | -- { \ 3 -> 4 155 | -- } 156 | -- -- xs 157 | -- 1 : 2 : 3 : []@ 158 | -- 159 | -- Which says, the return is @[2,3,4]@, there were @3@ calls to +1 160 | -- (showing arguments and results), and @xs@, which was the list 161 | -- @1 : 2 : 3 : []@. 162 | -- 163 | 164 | runO :: IO a -> IO () 165 | runO program = 166 | do { cdss <- debugO program 167 | ; let cdss1 = rmEntrySet cdss 168 | ; let cdss2 = simplifyCDSSet cdss1 169 | ; let output1 = cdssToOutput cdss2 170 | ; let output2 = commonOutput output1 171 | ; let ptyout = pretty 80 $ foldr ((<>) . renderTop) nil output2 172 | ; hPutStrLn stderr "" 173 | ; hPutStrLn stderr ptyout 174 | } 175 | 176 | {- 177 | ************************************************************************ 178 | * * 179 | Simulations 180 | * * 181 | ************************************************************************ 182 | 183 | Here we provide stubs for the functionally that is not supported 184 | by some compilers, and provide some combinators of various flavors. 185 | -} 186 | 187 | 188 | ourCatchAllIO :: IO a -> (Exception.SomeException -> IO a) -> IO a 189 | ourCatchAllIO = Exception.catch 190 | 191 | handleExc :: Parent -> Exception.SomeException -> IO a 192 | handleExc context exc = return (send "throw" (return throw << exc) context) 193 | 194 | {- 195 | ************************************************************************ 196 | * * 197 | Instances 198 | * * 199 | ************************************************************************ 200 | 201 | The Haskell Base types 202 | -} 203 | 204 | instance Observable Int where { observer = observeBase } 205 | instance Observable Bool where { observer = observeBase } 206 | instance Observable Integer where { observer = observeBase } 207 | instance Observable Float where { observer = observeBase } 208 | instance Observable Double where { observer = observeBase } 209 | instance Observable Char where { observer = observeBase } 210 | 211 | instance Observable () where { observer = observeOpaque "()" } 212 | 213 | -- utilities for base types. 214 | -- The strictness (by using seq) is the same 215 | -- as the pattern matching done on other constructors. 216 | -- we evalute to WHNF, and not further. 217 | 218 | observeBase :: (Show a) => a -> Parent -> a 219 | observeBase lit cxt = seq lit $ send (show lit) (return lit) cxt 220 | 221 | observeOpaque :: String -> a -> Parent -> a 222 | observeOpaque str val cxt = seq val $ send str (return val) cxt 223 | 224 | -- The Constructors. 225 | 226 | instance (Observable a,Observable b) => Observable (a,b) where 227 | observer (a,b) = send "," (return (,) << a << b) 228 | 229 | instance (Observable a,Observable b,Observable c) => Observable (a,b,c) where 230 | observer (a,b,c) = send "," (return (,,) << a << b << c) 231 | 232 | instance (Observable a,Observable b,Observable c,Observable d) 233 | => Observable (a,b,c,d) where 234 | observer (a,b,c,d) = send "," (return (,,,) << a << b << c << d) 235 | 236 | instance (Observable a,Observable b,Observable c,Observable d,Observable e) 237 | => Observable (a,b,c,d,e) where 238 | observer (a,b,c,d,e) = send "," (return (,,,,) << a << b << c << d << e) 239 | 240 | instance (Observable a) => Observable [a] where 241 | observer (a:as) = send ":" (return (:) << a << as) 242 | observer [] = send "[]" (return []) 243 | 244 | instance (Observable a) => Observable (Maybe a) where 245 | observer (Just a) = send "Just" (return Just << a) 246 | observer Nothing = send "Nothing" (return Nothing) 247 | 248 | instance (Observable a,Observable b) => Observable (Either a b) where 249 | observer (Left a) = send "Left" (return Left << a) 250 | observer (Right a) = send "Right" (return Right << a) 251 | 252 | -- Arrays. 253 | 254 | instance (Ix a,Observable a,Observable b) => Observable (Array.Array a b) where 255 | observer arr = send "array" (return Array.array << Array.bounds arr 256 | << Array.assocs arr 257 | ) 258 | 259 | -- IO monad. 260 | 261 | instance (Observable a) => Observable (IO a) where 262 | observer fn cxt = 263 | do res <- fn 264 | send "" (return return << res) cxt 265 | 266 | 267 | -- Functions. 268 | 269 | instance (Observable a,Observable b) => Observable (a -> b) where 270 | observer fn cxt arg = sendObserveFnPacket ( 271 | do arg <- thunk arg 272 | thunk (fn arg)) cxt 273 | 274 | observers = defaultFnObservers 275 | 276 | -- The Exception *datatype* (not exceptions themselves!). 277 | -- For now, we only display IOExceptions and calls to Error. 278 | 279 | instance Observable Exception.SomeException where 280 | -- observer (IOException a) = observeOpaque "IOException" (IOException a) 281 | -- observer (ErrorCall a) = send "ErrorCall" (return ErrorCall << a) 282 | observer other = send "" (return other) 283 | 284 | instance Observable Dynamic where { observer = observeOpaque "" } 285 | 286 | {- 287 | ************************************************************************ 288 | * * 289 | Classes and Data Definition 290 | * * 291 | ************************************************************************ 292 | -} 293 | 294 | -- | The 'Observable' class defines how data types are observed. 295 | -- For 'Generic' data types, this can be derived. For example: 296 | -- 297 | -- @ 298 | -- data MyType = MyConstr Int String deriving 'Generic' 299 | -- instance 'Observable' MyType 300 | -- @ 301 | class Observable a where 302 | {- 303 | - This reveals the name of a specific constructor. 304 | - and gets ready to explain the sub-components. 305 | - 306 | - We put the context second so we can do eta-reduction 307 | - with some of our definitions. 308 | -} 309 | observer :: a -> Parent -> a 310 | default observer :: (Generic a, GObservable (Rep a)) => a -> Parent -> a 311 | observer x c = to (gdmobserver (from x) c) 312 | 313 | {- 314 | - This used used to group several observer instances together. 315 | -} 316 | observers :: String -> (Observer -> a) -> a 317 | observers = defaultObservers 318 | 319 | class GObservable f where 320 | gdmobserver :: f a -> Parent -> f a 321 | gdmObserveChildren :: f a -> ObserverM (f a) 322 | gdmShallowShow :: f a -> String 323 | 324 | -- Meta: data types 325 | instance (GObservable a) => GObservable (M1 D d a) where 326 | gdmobserver m@(M1 x) cxt = M1 (gdmobserver x cxt) 327 | gdmObserveChildren = gthunk 328 | gdmShallowShow = error "gdmShallowShow not defined on <>" 329 | 330 | -- Meta: Selectors 331 | instance (GObservable a, Selector s) => GObservable (M1 S s a) where 332 | gdmobserver m@(M1 x) cxt 333 | = M1 (gdmobserver x cxt) 334 | -- Uncomment next two lines to record selector names 335 | -- selName m == "" = M1 (gdmobserver x cxt) 336 | -- otherwise = M1 (send (selName m ++ " =") (gdmObserveChildren x) cxt) 337 | gdmObserveChildren = gthunk 338 | gdmShallowShow = error "gdmShallowShow not defined on <>" 339 | 340 | -- Meta: Constructors 341 | instance (GObservable a, Constructor c) => GObservable (M1 C c a) where 342 | gdmobserver m1 = send (gdmShallowShow m1) (gdmObserveChildren m1) 343 | gdmObserveChildren (M1 x) = do {x' <- gdmObserveChildren x; return (M1 x')} 344 | gdmShallowShow = conName 345 | 346 | -- Unit: used for constructors without arguments 347 | instance GObservable U1 where 348 | gdmobserver x _ = x 349 | gdmObserveChildren = return 350 | gdmShallowShow = error "gdmShallowShow not defined on <>" 351 | 352 | -- Sums: encode choice between constructors 353 | instance (GObservable a, GObservable b) => GObservable (a :+: b) where 354 | gdmobserver (L1 x) = send (gdmShallowShow x) (gdmObserveChildren $ L1 x) 355 | gdmobserver (R1 x) = send (gdmShallowShow x) (gdmObserveChildren $ R1 x) 356 | gdmShallowShow (L1 x) = gdmShallowShow x 357 | gdmShallowShow (R1 x) = gdmShallowShow x 358 | gdmObserveChildren (L1 x) = do {x' <- gdmObserveChildren x; return (L1 x')} 359 | gdmObserveChildren (R1 x) = do {x' <- gdmObserveChildren x; return (R1 x')} 360 | 361 | -- Products: encode multiple arguments to constructors 362 | instance (GObservable a, GObservable b) => GObservable (a :*: b) where 363 | gdmobserver (a :*: b) cxt = gdmobserver a cxt :*: gdmobserver b cxt 364 | gdmObserveChildren (a :*: b) = do a' <- gdmObserveChildren a 365 | b' <- gdmObserveChildren b 366 | return (a' :*: b') 367 | gdmShallowShow = error "gdmShallowShow not defined on <>" 368 | 369 | -- Constants: additional parameters and recursion of kind * 370 | instance (Observable a) => GObservable (K1 i a) where 371 | gdmobserver (K1 x) cxt = K1 $ observer x cxt 372 | gdmObserveChildren = gthunk 373 | gdmShallowShow = error "gdmShallowShow not defined on <>" 374 | 375 | gthunk :: (GObservable f) => f a -> ObserverM (f a) 376 | gthunk a = ObserverM $ \ parent port -> 377 | ( gdmobserver_ a Parent 378 | { observeParent = parent 379 | , observePort = port 380 | } 381 | , port+1 ) 382 | 383 | gdmobserver_ :: (GObservable f) => f a -> Parent -> f a 384 | gdmobserver_ = gsendEnterPacket 385 | 386 | gsendEnterPacket :: (GObservable f) => f a -> Parent -> f a 387 | gsendEnterPacket r context = unsafeWithUniq $ \ node -> 388 | do { sendEvent node context Enter 389 | ; ourCatchAllIO (evaluate (gdmobserver r context)) 390 | (handleExc context) 391 | } 392 | 393 | type Observing a = a -> a 394 | 395 | newtype Observer = O (forall a . (Observable a) => String -> a -> a) 396 | 397 | defaultObservers :: (Observable a) => String -> (Observer -> a) -> a 398 | defaultObservers label fn = unsafeWithUniq $ \ node -> 399 | do { sendEvent node (Parent 0 0) (Observe label) 400 | ; let observe' sublabel a 401 | = unsafeWithUniq $ \ subnode -> 402 | do { sendEvent subnode (Parent node 0) 403 | (Observe sublabel) 404 | ; return (observer_ a Parent 405 | { observeParent = subnode 406 | , observePort = 0 407 | }) 408 | } 409 | ; return (observer_ (fn (O observe')) 410 | Parent 411 | { observeParent = node 412 | , observePort = 0 413 | }) 414 | } 415 | defaultFnObservers :: (Observable a, Observable b) 416 | => String -> (Observer -> a -> b) -> a -> b 417 | defaultFnObservers label fn arg = unsafeWithUniq $ \ node -> 418 | do { sendEvent node (Parent 0 0) (Observe label) 419 | ; let observe' sublabel a 420 | = unsafeWithUniq $ \ subnode -> 421 | do { sendEvent subnode (Parent node 0) 422 | (Observe sublabel) 423 | ; return (observer_ a Parent 424 | { observeParent = subnode 425 | , observePort = 0 426 | }) 427 | } 428 | ; return (observer_ (fn (O observe')) 429 | Parent 430 | { observeParent = node 431 | , observePort = 0 432 | } arg) 433 | } 434 | 435 | {- 436 | ************************************************************************ 437 | * * 438 | The ObserveM Monad 439 | * * 440 | ************************************************************************ 441 | 442 | The Observer monad, a simple state monad, 443 | for placing numbers on sub-observations. 444 | -} 445 | 446 | newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) } 447 | 448 | instance Functor ObserverM where 449 | fmap = liftM 450 | 451 | instance Applicative ObserverM where 452 | pure = return 453 | (<*>) = ap 454 | 455 | instance Monad ObserverM where 456 | return a = ObserverM (\ c i -> (a,i)) 457 | fn >>= k = ObserverM (\ c i -> 458 | case runMO fn c i of 459 | (r,i2) -> runMO (k r) c i2 460 | ) 461 | 462 | thunk :: (Observable a) => a -> ObserverM a 463 | thunk a = ObserverM $ \ parent port -> 464 | ( observer_ a Parent 465 | { observeParent = parent 466 | , observePort = port 467 | } 468 | , port+1 ) 469 | 470 | (<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b 471 | fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') } 472 | 473 | {- 474 | ************************************************************************ 475 | * * 476 | observe and friends 477 | * * 478 | ************************************************************************ 479 | 480 | Our principal function and class 481 | -} 482 | 483 | -- | 'observe' observes data structures in flight. 484 | -- 485 | -- An example of use is 486 | -- @ 487 | -- map (+1) . observe \"intermeduate\" . map (+2) 488 | -- @ 489 | -- 490 | -- In this example, we observe the value that flows from the producer 491 | -- @map (+2)@ to the consumer @map (+1)@. 492 | -- 493 | -- 'observe' can also observe functions as well a structural values. 494 | -- 495 | {-# NOINLINE observe #-} 496 | observe :: (Observable a) => String -> a -> a 497 | observe = generateContext 498 | 499 | {- This gets called before observer, allowing us to mark 500 | - we are entering a, before we do case analysis on 501 | - our object. 502 | -} 503 | 504 | {-# NOINLINE observer_ #-} 505 | observer_ :: (Observable a) => a -> Parent -> a 506 | observer_ = sendEnterPacket 507 | 508 | data Parent = Parent 509 | { observeParent :: !Int -- my parent 510 | , observePort :: !Int -- my branch number 511 | } deriving Show 512 | root = Parent 0 0 513 | 514 | 515 | -- The functions that output the data. All are dirty. 516 | 517 | unsafeWithUniq :: (Int -> IO a) -> a 518 | unsafeWithUniq fn 519 | = unsafePerformIO $ do { node <- readUniq 520 | ; r <- fn node 521 | ; incrementUniq node 522 | ; return r 523 | } 524 | 525 | generateContext :: (Observable a) => String -> a -> a 526 | generateContext label orig = unsafeWithUniq $ \ node -> 527 | do { sendEvent node (Parent 0 0) (Observe label) 528 | ; return (observer_ orig Parent 529 | { observeParent = node 530 | , observePort = 0 531 | } 532 | ) 533 | } 534 | 535 | send :: String -> ObserverM a -> Parent -> a 536 | send consLabel fn context = unsafeWithUniq $ \ node -> 537 | do { let (r,portCount) = runMO fn node 0 538 | ; sendEvent node context (Cons portCount consLabel) 539 | ; return r 540 | } 541 | 542 | sendEnterPacket :: (Observable a) => a -> Parent -> a 543 | sendEnterPacket r context = unsafeWithUniq $ \ node -> 544 | do { sendEvent node context Enter 545 | ; ourCatchAllIO (evaluate (observer r context)) 546 | (handleExc context) 547 | } 548 | 549 | evaluate :: a -> IO a 550 | evaluate a = a `seq` return a 551 | 552 | 553 | sendObserveFnPacket :: ObserverM a -> Parent -> a 554 | sendObserveFnPacket fn context = unsafeWithUniq $ \ node -> 555 | do { let (r,_) = runMO fn node 0 556 | ; sendEvent node context Fun 557 | ; return r 558 | } 559 | 560 | {- 561 | ************************************************************************ 562 | * * 563 | Event stream 564 | * * 565 | ************************************************************************ 566 | 567 | Trival output functions 568 | -} 569 | 570 | data Event = Event 571 | { portId :: !Int 572 | , parent :: !Parent 573 | , change :: !Change 574 | } 575 | deriving Show 576 | 577 | data Change 578 | = Observe !String 579 | | Cons !Int !String 580 | | Enter 581 | | Fun 582 | deriving Show 583 | 584 | startEventStream :: IO () 585 | startEventStream = writeIORef events [] 586 | 587 | endEventStream :: IO [Event] 588 | endEventStream = 589 | do { es <- readIORef events 590 | ; writeIORef events badEvents 591 | ; return es 592 | } 593 | 594 | sendEvent :: Int -> Parent -> Change -> IO () 595 | sendEvent nodeId parent change = 596 | do { nodeId `seq` parent `seq` return () 597 | ; change `seq` return () 598 | ; takeMVar sendSem 599 | ; es <- readIORef events 600 | ; let event = Event nodeId parent change 601 | ; writeIORef events (event `seq` (event : es)) 602 | ; putMVar sendSem () 603 | } 604 | 605 | -- local 606 | {-# NOINLINE events #-} 607 | events :: IORef [Event] 608 | events = unsafePerformIO $ newIORef badEvents 609 | 610 | badEvents :: [Event] 611 | badEvents = error "Bad Event Stream" 612 | 613 | -- use as a trivial semiphore 614 | {-# NOINLINE sendSem #-} 615 | sendSem :: MVar () 616 | sendSem = unsafePerformIO $ newMVar () 617 | -- end local 618 | 619 | {- 620 | ************************************************************************ 621 | * * 622 | Unique name supply code 623 | * * 624 | ************************************************************************ 625 | 626 | Use the single threaded version 627 | -} 628 | 629 | initUniq :: IO () 630 | initUniq = writeIORef uniq 1 631 | 632 | incrementUniq :: Int -> IO () 633 | incrementUniq n = writeIORef uniq $! (n + 1) 634 | 635 | readUniq :: IO Int 636 | readUniq = readIORef uniq 637 | 638 | -- locals 639 | {-# NOINLINE uniq #-} 640 | uniq :: IORef Int 641 | uniq = unsafePerformIO $ newIORef 1 642 | 643 | {-# NOINLINE uniqSem #-} 644 | uniqSem :: MVar () 645 | uniqSem = unsafePerformIO $ newMVar () 646 | 647 | {- 648 | ************************************************************************ 649 | * * 650 | Global, initualizers, etc 651 | * * 652 | ************************************************************************ 653 | -} 654 | 655 | openObserveGlobal :: IO () 656 | openObserveGlobal = 657 | do { initUniq 658 | ; startEventStream 659 | } 660 | 661 | closeObserveGlobal :: IO [Event] 662 | closeObserveGlobal = 663 | do { evs <- endEventStream 664 | ; putStrLn "" 665 | ; return evs 666 | } 667 | 668 | {- 669 | ************************************************************************ 670 | * * 671 | The CDS and converting functions 672 | * * 673 | ************************************************************************ 674 | -} 675 | 676 | data CDS = CDSNamed String CDSSet 677 | | CDSCons Int String [CDSSet] 678 | | CDSFun Int CDSSet CDSSet 679 | | CDSEntered Int 680 | deriving (Show,Eq,Ord) 681 | 682 | type CDSSet = [CDS] 683 | 684 | 685 | eventsToCDS :: [Event] -> CDSSet 686 | eventsToCDS pairs = getChild 0 0 687 | where 688 | res = (!) out_arr 689 | 690 | bnds = (0, length pairs) 691 | 692 | mid_arr :: Array Int [(Int,CDS)] 693 | mid_arr = accumArray (flip (:)) [] bnds 694 | [ (pnode,(pport,res node)) 695 | | (Event node (Parent pnode pport) _) <- pairs 696 | ] 697 | 698 | out_arr = array bnds -- never uses 0 index 699 | [ (node,getNode'' node change) 700 | | (Event node _ change) <- pairs 701 | ] 702 | 703 | getNode'' :: Int -> Change -> CDS 704 | getNode'' node change = 705 | case change of 706 | (Observe str) -> CDSNamed str (getChild node 0) 707 | (Enter) -> CDSEntered node 708 | (Fun) -> CDSFun node (getChild node 0) (getChild node 1) 709 | (Cons portc cons) 710 | -> CDSCons node cons 711 | [ getChild node n | n <- [0..(portc-1)]] 712 | 713 | getChild :: Int -> Int -> CDSSet 714 | getChild pnode pport = 715 | [ content 716 | | (pport',content) <- (!) mid_arr pnode 717 | , pport == pport' 718 | ] 719 | 720 | render :: Int -> Bool -> CDS -> Doc 721 | render prec par (CDSCons _ ":" [cds1,cds2]) = 722 | if par && not needParen 723 | then doc -- dont use paren (..) because we dont want a grp here! 724 | else paren needParen doc 725 | where 726 | doc = grp (softline <> renderSet' 5 False cds1 <> text " : ") <> 727 | renderSet' 4 True cds2 728 | needParen = prec > 4 729 | render prec par (CDSCons _ "," cdss) | length cdss > 0 = 730 | nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b) 731 | (map renderSet cdss) <> 732 | text ")") 733 | render prec par (CDSCons _ name cdss) = 734 | paren (length cdss > 0 && prec /= 0) 735 | (nest 2 736 | (text name <> foldr (<>) nil 737 | [ softline <> renderSet' 10 False cds 738 | | cds <- cdss 739 | ] 740 | ) 741 | ) 742 | 743 | {- renderSet handles the various styles of CDSSet. 744 | -} 745 | 746 | renderSet :: CDSSet -> Doc 747 | renderSet = renderSet' 0 False 748 | 749 | renderSet' :: Int -> Bool -> CDSSet -> Doc 750 | renderSet' _ _ [] = text "_" 751 | renderSet' prec par [cons@(CDSCons {})] = render prec par cons 752 | renderSet' prec par cdss = 753 | nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <> 754 | text ", " <> b) 755 | (map renderFn pairs) <> 756 | line <> text "}") 757 | 758 | where 759 | pairs = nub (sort (findFn cdss)) 760 | -- local nub for sorted lists 761 | nub [] = [] 762 | nub (a:a':as) | a == a' = nub (a' : as) 763 | nub (a:as) = a : nub as 764 | 765 | renderFn :: ([CDSSet],CDSSet) -> Doc 766 | renderFn (args,res) 767 | = grp (nest 3 768 | (text "\\ " <> 769 | foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b) 770 | nil 771 | args <> softline <> 772 | text "-> " <> renderSet' 0 False res 773 | ) 774 | ) 775 | 776 | findFn :: CDSSet -> [([CDSSet],CDSSet)] 777 | findFn = foldr findFn' [] 778 | 779 | findFn' (CDSFun _ arg res) rest = 780 | case findFn res of 781 | [(args',res')] -> (arg : args', res') : rest 782 | _ -> ([arg], res) : rest 783 | findFn' other rest = ([],[other]) : rest 784 | 785 | renderTops [] = nil 786 | renderTops tops = line <> foldr ((<>) . renderTop ) nil tops 787 | 788 | renderTop :: Output -> Doc 789 | renderTop (OutLabel str set extras) = 790 | nest 2 (text ("-- " ++ str) <> line <> 791 | renderSet set 792 | <> renderTops extras) <> line 793 | 794 | rmEntry :: CDS -> CDS 795 | rmEntry (CDSNamed str set) = CDSNamed str (rmEntrySet set) 796 | rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets) 797 | rmEntry (CDSFun i a b) = CDSFun i (rmEntrySet a) (rmEntrySet b) 798 | rmEntry (CDSEntered i) = error "found bad CDSEntered" 799 | 800 | rmEntrySet = map rmEntry . filter noEntered 801 | where 802 | noEntered (CDSEntered _) = False 803 | noEntered _ = True 804 | 805 | simplifyCDS :: CDS -> CDS 806 | simplifyCDS (CDSNamed str set) = CDSNamed str (simplifyCDSSet set) 807 | simplifyCDS (CDSCons _ "throw" 808 | [[CDSCons _ "ErrorCall" set]] 809 | ) = simplifyCDS (CDSCons 0 "error" set) 810 | simplifyCDS cons@(CDSCons i str sets) = 811 | case spotString [cons] of 812 | Just str | not (null str) -> CDSCons 0 (show str) [] 813 | _ -> CDSCons 0 str (map simplifyCDSSet sets) 814 | 815 | simplifyCDS (CDSFun i a b) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b) 816 | -- replace with 817 | -- CDSCons i "->" [simplifyCDSSet a,simplifyCDSSet b] 818 | -- for turning off the function stuff. 819 | 820 | simplifyCDSSet = map simplifyCDS 821 | 822 | spotString :: CDSSet -> Maybe String 823 | spotString [CDSCons _ ":" 824 | [[CDSCons _ str []] 825 | ,rest 826 | ] 827 | ] 828 | = do { ch <- case reads str of 829 | [(ch,"")] -> return ch 830 | _ -> Nothing 831 | ; more <- spotString rest 832 | ; return (ch : more) 833 | } 834 | spotString [CDSCons _ "[]" []] = return [] 835 | spotString other = Nothing 836 | 837 | paren :: Bool -> Doc -> Doc 838 | paren False doc = grp (nest 0 doc) 839 | -- paren True doc = grp (nest 0 (text "(" <> nest 0 doc <> softline <> text ")")) 840 | paren True doc = grp (text "(" <> doc <> softline <> text ")") 841 | 842 | sp :: Doc 843 | sp = text " " 844 | 845 | data Output = OutLabel String CDSSet [Output] 846 | | OutData CDS 847 | deriving (Eq,Ord) 848 | 849 | 850 | commonOutput :: [Output] -> [Output] 851 | commonOutput = sortBy byLabel 852 | where 853 | byLabel (OutLabel lab _ _) (OutLabel lab' _ _) = compare lab lab' 854 | 855 | cdssToOutput :: CDSSet -> [Output] 856 | cdssToOutput = map cdsToOutput 857 | 858 | cdsToOutput (CDSNamed name cdsset) 859 | = OutLabel name res1 res2 860 | where 861 | res1 = [ cdss | (OutData cdss) <- res ] 862 | res2 = [ out | out@(OutLabel {}) <- res ] 863 | res = cdssToOutput cdsset 864 | cdsToOutput cons@(CDSCons {}) = OutData cons 865 | cdsToOutput fn@(CDSFun {}) = OutData fn 866 | 867 | nil = Text.PrettyPrint.FPretty.empty 868 | grp = Text.PrettyPrint.FPretty.group 869 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Haskell Object Observation Debugging toolkit (HOOD) is Copyright 2 | (c) Andy Gill, 2000, (c) The University of Kansas, 2010-2015. 3 | 4 | All rights reserved, and is distributed as free software under the 5 | following license. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 11 | - Redistributions of source code must retain the above copyright notice, 12 | this list of conditions and the following disclaimer. 13 | 14 | - Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | - Neither name of the copyright holders nor the names of its 19 | contributors may be used to endorse or promote products derived from 20 | this software without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS 23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 25 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 26 | HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 27 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 28 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS 29 | OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 30 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR 31 | TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE 32 | USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `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) 2 | 3 | Hood debugger, based on the idea of observing functions and structures as they are evaluated. 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /hood.cabal: -------------------------------------------------------------------------------- 1 | Name: hood 2 | Version: 0.3.1 3 | Synopsis: Debugging by observing in place 4 | Description: Hood debugger, based on the idea of observing functions and structures as they are evaluated. 5 | Category: Debug, Trace 6 | License: BSD3 7 | License-file: LICENSE 8 | Author: Andy Gill 9 | Maintainer: Andy Gill 10 | Copyright: (c) 2000 Andy Gill, (c) 2010-2015 University of Kansas, (c) 2013-2015 Maarten Faddegon 11 | Homepage: http://ku-fpg.github.io/software/hood 12 | bug-reports: https://github.com/ku-fpg/hood/issues 13 | Stability: alpha 14 | build-type: Simple 15 | Cabal-Version: >= 1.8 16 | tested-with: GHC == 7.4.2 17 | , GHC == 7.6.3 18 | , GHC == 7.8.4 19 | , GHC == 7.10.3 20 | , GHC == 8.0.2 21 | , GHC == 8.2.2 22 | , GHC == 8.4.3 23 | extra-source-files: CHANGELOG.md, README.md 24 | 25 | Library 26 | Build-Depends: base >= 4.5 && < 5, array, FPretty, ghc-prim 27 | Exposed-modules: 28 | Debug.Hood.Observe 29 | 30 | Test-Suite hood-test 31 | Type: exitcode-stdio-1.0 32 | Hs-Source-Dirs: test 33 | Main-Is: test.hs 34 | Build-Depends: base, ghc-prim, hood 35 | 36 | source-repository head 37 | type: git 38 | location: https://github.com/ku-fpg/hood 39 | -------------------------------------------------------------------------------- /test/test.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | {-# LANGUAGE DeriveGeneric #-} 3 | -- stack --resolver lts-8.4 runghc --package hood 4 | -- Minimum program to reproduce https://github.com/ku-fpg/hood/issues/5 5 | 6 | import Debug.Hood.Observe 7 | import GHC.Generics 8 | 9 | 10 | data Hoge = 11 | Hoge 12 | { hoge1 :: Int 13 | , hoge2 :: String 14 | } deriving Generic 15 | 16 | instance Observable Hoge 17 | 18 | 19 | main :: IO () 20 | main = runO $ print $ f undefined 21 | 22 | 23 | f :: Hoge -> Bool 24 | f = observe "f" f' 25 | f' :: Hoge -> Bool 26 | f' h@(Hoge _h1 _h2) = error "ERROR" 27 | --------------------------------------------------------------------------------