darcs - GHood

2 -----------------------------------------------------------------------------

3 -- |

4 -- Module : Debug.Observe

5 -- Copyright :

6 -- License : BSD3

7 --

8 -- Maintainer : hpacheco@di.uminho.pt

9 -- Stability : experimental

10 -- Portability : non-portable

11 --

12 -- GHood:

13 -- A graphical viewer for Hood

14 --

15 --

16 -- Created a cabal library package.

17 -- Improved the search for the GHood.jar file, that is bundled with the library.

18 -- Changed from Literate Haskell to plain Haskell for better haddock documentation support.

19 --

20 -- Hugo Pacheco, November 2008

21 --

22 -- Added ObserveM.

23 -- Adapted imports to use GHC's hierarchical libraries.

24 --

25 -- Alcino Cunha, February 2004

26 --

27 -- Modified version of Hood/Observe.lhs to match GHood,

28 -- the Graphical Haskell Object Observation Debugger, which

29 -- is distributed as a Java class file archive GHood.jar.

30 -- [Apart from two new hooks, modifications are at the end]

31 --

32 -- Claus Reinke, December 2000

33 --

34 -- The file is part of the Haskell Object Observation Debugger,

35 -- (HOOD) July 2000 release. Actually this is all of this version

36 -- of HOOD, apart from the documentation and examples...

37 --

38 -- HOOD is a small post-mortem debugger for the lazy functional

39 -- language Haskell. It is based on the concept of observation of

40 -- intermediate data structures, rather than the more traditional

41 -- stepping and variable examination paradigm used by imperative

42 -- language debuggers.

43 --

44 -- Copyright (c) Andy Gill, 1992-2000

47 -- the license in the file "License", which available from the HOOD

48 -- web page, http://www.haskell.org/hood

50 -- This module produces CDS's, based on the observation made on Haskell

51 -- objects, including base types, constructors and functions.

52 --

53 -----------------------------------------------------------------------------

56 module Debug.Observe (

57 observe

58 , Observer(..)

59 , Observing

60 , Observable(..)

61 , runO

62 , printO

63 , putStrO

64 , ObserverM(..)

65 -- * For advanced users, that want to render their own datatypes.

66 , (<<)

67 , thunk

68 , send

69 , observeBase

70 , observeOpaque

71 , Parent(..)

72 -- * For users that want to write their own render drivers.

73 , debugO

74 , CDS(..)

75 , CDSSet

77 ) where

79 import IO

80 import Maybe

81 import Monad

82 import Array

83 import List

84 import System

85 import Data.IORef

86 import Control.Concurrent

87 -- The library-dependent import

88 import Paths_GHood

89 -- The only non standard one we assume

90 import System.IO.Unsafe

92 infixl 9 <<

94 -- * External start functions

96 -- | Debugs observe ridden code.

97 debugO :: IO a -> IO [CDS]

98 debugO program =

99 do { initUniq

100 ; startEventStream

101 ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"

102 ; ourCatchAllIO (do { program ; return () })

103 (hPutStrLn stderr . errorMsg)

104 ; events <- endEventStream

105 ; return (eventsToCDS events)

106 }

107

108 -- | Runs and prints observe ridden code.

109 printO :: (Show a) => a -> IO ()

110 printO = runO . print

111

112 -- | Prints a string during observation.

113 putStrO :: String -> IO ()

114 putStrO = runO . putStr

115

116 -- | Runs observe ridden code.

117 runO :: IO a -> IO ()

118 runO program =

119 do { cdss <- debugO program

120 ; let cdss1 = rmEntrySet cdss

121 ; let cdss2 = simplifyCDSSet cdss1

122 ; let output1 = cdssToOutput cdss2

123 ; let output2 = commonOutput output1

124 ; let ptyout = pretty 80 (foldr (<>) nil (map renderTop output2))

125 ; hPutStrLn stderr ""

126 ; hPutStrLn stderr ptyout

127 }

128

129 -- * Simulations

130

131 -- Here we provide stubs for the functionally that is not supported

132 -- by some compilers, and provide some combinators of various flavors.

133

134 ourCatchAllIO :: IO a -> (() -> IO a) -> IO a

135 ourCatchAllIO = const

136

137 handleExc :: (Observable a) => Parent -> () -> IO a

138 handleExc = undefined

139

140 -- * Instances

141

142 -- The Haskell Base types

143

144 instance Observable Int where { observer = observeBase }

145 instance Observable Bool where { observer = observeBase }

146 instance Observable Integer where { observer = observeBase }

147 instance Observable Float where { observer = observeBase }

148 instance Observable Double where { observer = observeBase }

149 instance Observable Char where { observer = observeBase }

150

151 instance Observable () where { observer = observeOpaque "()" }

152

153 -- | Observe a base type

154 observeBase :: (Show a) => a -> Parent -> a

155 observeBase lit = seq lit . send (show lit) (return lit)

156 -- ^ The strictness (by using seq) is the same as the pattern matching done on other constructors.

157 -- We evaluate to WHNF, and not further.

158

159 -- | Observe a base type as an 'opaque' string.

160 observeOpaque :: String -> a -> Parent -> a

161 observeOpaque str val = seq val . send str (return val)

162

163 -- The Constructors.

164

165 instance (Observable a,Observable b) => Observable (a,b) where

166 observer (a,b) = send "," (return (,) << a << b)

167

168 instance (Observable a,Observable b,Observable c) => Observable (a,b,c) where

169 observer (a,b,c) = send "," (return (,,) << a << b << c)

170

171 instance (Observable a,Observable b,Observable c,Observable d)

172 => Observable (a,b,c,d) where

173 observer (a,b,c,d) = send "," (return (,,,) << a << b << c << d)

174

175 instance (Observable a,Observable b,Observable c,Observable d,Observable e)

176 => Observable (a,b,c,d,e) where

177 observer (a,b,c,d,e) = send "," (return (,,,,) << a << b << c << d << e)

178

179 instance (Observable a) => Observable [a] where

180 observer (a:as) = send ":" (return (:) << a << as)

181 observer [] = send "[]" (return [])

182

183 instance (Observable a) => Observable (Maybe a) where

184 observer (Just a) = send "Just" (return Just << a)

185 observer Nothing = send "Nothing" (return Nothing)

186

187 instance (Observable a,Observable b) => Observable (Either a b) where

188 observer (Left a) = send "Left" (return Left << a)

189 observer (Right a) = send "Right" (return Right << a)

190

191 -- Arrays.

192

193 instance (Ix a,Observable a,Observable b) => Observable (Array.Array a b) where

194 observer arr = send "array" (return Array.array << Array.bounds arr

195 << Array.assocs arr)

196

197 -- IO monad.

198

199 instance (Observable a) => Observable (IO a) where

200 observer fn cxt =

201 do res <- fn

202 send "<IO>" (return return << res) cxt

203

204 -- We treat IOError this like a base value. Cheating a bit, but if you

205 -- generate an IOError with a bottom in it, your just asking for trouble.

206

207 instance Observable IOError where

208 observer = observeBase

209

210 -- Functions.

211

212 instance (Observable a,Observable b) => Observable (a -> b) where

213 observer fn cxt arg = sendObserveFnPacket (

214 do arg <- thunk arg

215 thunk (fn arg)) cxt

216

217 observers = defaultFnObservers

218

219 -- The Exception *datatype* (not exceptions themselves!).

220 -- For now, we only display IOExceptions and calls to Error.

221

222 -- * Classes and Data Defintions

223

224 class Observable a where

225 {-|

226 This reveals the name of a specific constructor.

227 and gets ready to explain the sub-components.

228 We put the context second so we can do eta-reduction

229 with some of our definitions.

230 -}

231 observer :: a -> Parent -> a

232 {-|

233 This used used to group several observer instances together.

234 -}

235 observers :: String -> (Observer -> a) -> a

236 observers = defaultObservers

237

238 type Observing a = a -> a

239

240 -- | Contains a 'forall' typed observe (if supported).

241 newtype Observer = O (forall a . (Observable a) => String -> a -> a)

242

243 defaultObservers :: (Observable a) => String -> (Observer -> a) -> a

244 defaultObservers label fn = unsafeWithUniq $ \ node ->

245 do { sendEvent node (Parent 0 0) (Observe label)

246 ; let observe' sublabel a

247 = unsafeWithUniq $ \ subnode ->

248 do { sendEvent subnode (Parent node 0)

249 (Observe sublabel)

250 ; return (observer_ a Parent

251 { observeParent = subnode

252 , observePort = 0

253 })

254 }

255 ; return (observer_ (fn (O observe'))

256 Parent

257 { observeParent = node

258 , observePort = 0

259 })

260 }

261 defaultFnObservers :: (Observable a,Observable b) => String -> (Observer -> a -> b) -> a -> b

262 defaultFnObservers label fn arg = unsafeWithUniq $ \ node ->

263 do { sendEvent node (Parent 0 0) (Observe label)

264 ; let observe' sublabel a

265 = unsafeWithUniq $ \ subnode ->

266 do { sendEvent subnode (Parent node 0)

267 (Observe sublabel)

268 ; return (observer_ a Parent

269 { observeParent = subnode

270 , observePort = 0

271 })

272 }

273 ; return (observer_ (fn (O observe'))

274 Parent

275 { observeParent = node

276 , observePort = 0

277 } arg)

278 }

279

280 -- * The ObserveM Monad

281

282 -- | A simple state monad for placing numbers on sub-observations.

283 newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) }

284

285 instance Monad ObserverM where

286 return a = ObserverM (\ c i -> (a,i))

287 fn >>= k = ObserverM (\ c i ->

288 case runMO fn c i of

289 (r,i2) -> runMO (k r) c i2

290 )

291

292 -- | thunk is for marking suspensions.

293 thunk :: (Observable a) => a -> ObserverM a

294 thunk a = ObserverM $ \ parent port ->

295 ( observer_ a Parent

296 { observeParent = parent

297 , observePort = port

298 }

299 , port+1 )

300

301 -- | the infix (<<) is a shortcut for constructor arguments.

302 (<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b

303 fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') }

304

305 -- * Observe and friends

306

307 {-# NOINLINE observe #-}

308 -- | Our principle function and class

309 observe :: (Observable a) => String -> a -> a

310 observe = generateContext

311

312 {-# NOINLINE observer_ #-}

313 {-|

314 This gets called before observer, allowing us to mark

315 we are entering a, before we do case analysis on

316 our object.

317 -}

318 observer_ :: (Observable a) => a -> Parent -> a

319 observer_ = sendEnterPacket

320

321 -- | Parent book-keeping information.

322 data Parent = Parent

323 { observeParent :: !Int -- ^ my parent

324 , observePort :: !Int -- ^ my branch number

325 } deriving Show

326 root = Parent 0 0

327

328 -- The functions that output the data. All are dirty.

329

330 unsafeWithUniq :: (Int -> IO a) -> a

331 unsafeWithUniq fn

332 = unsafePerformIO $ do { node <- getUniq

333 ; fn node

334 }

335

336 generateContext :: (Observable a) => String -> a -> a

337 generateContext label orig = unsafeWithUniq $ \ node ->

338 do { sendEvent node (Parent 0 0) (Observe label)

339 ; return (observer_ orig Parent

340 { observeParent = node

341 , observePort = 0

342 }

343 )

344 }

345

346 -- | Sends a packet to the observation agent.

347 send :: String -> ObserverM a -> Parent -> a

348 send consLabel fn context = unsafeWithUniq $ \ node ->

349 do { let (r,portCount) = runMO fn node 0

350 ; sendEvent node context (Cons portCount consLabel)

351 ; return r

352 }

353

354 sendEnterPacket :: (Observable a) => a -> Parent -> a

355 sendEnterPacket r context = unsafeWithUniq $ \ node ->

356 do { sendEvent node context Enter

357 ; ourCatchAllIO (evaluate (observer r context))

358 (handleExc context)

359 }

360

361 evaluate :: a -> IO a

362 evaluate a = a `seq` return a

363

364 sendObserveFnPacket :: ObserverM a -> Parent -> a

365 sendObserveFnPacket fn context = unsafeWithUniq $ \ node ->

366 do { let (r,_) = runMO fn node 0

367 ; sendEvent node context Fun

368 ; return r

369 }

370

371 -- * Event stream

372

373 -- Trival output functions

374

375 data Event = Event

376 { portId :: !Int

377 , parent :: !Parent

378 , change :: !Change

379 }

380 deriving Show

381

382 data Change

383 = Observe !String

384 | Cons !Int !String

385 | Enter

386 | Fun

387 deriving Show

388

389 startEventStream :: IO ()

390 startEventStream = writeIORef events []

391

392 endEventStream :: IO [Event]

393 endEventStream =

394 do { es <- readIORef events

395 ; writeIORef events badEvents

396 ; eventsHook es -- cr, use return () as default

397 ; return es

398 }

399

400 sendEvent :: Int -> Parent -> Change -> IO ()

401 sendEvent nodeId parent change =

402 do { nodeId `seq` parent `seq` return ()

403 ; change `seq` return ()

404 ; takeMVar sendSem

405 ; es <- readIORef events

406 ; let event = Event nodeId parent change

407 ; writeIORef events (event `seq` (event : es))

408 ; eventHook event -- cr, use return () as default

409 ; putMVar sendSem ()

410 }

411

412 -- local

413 events :: IORef [Event]

414 events = unsafePerformIO $ newIORef badEvents

415

416 badEvents :: [Event]

417 badEvents = error "Bad Event Stream"

418

419 {-# NOINLINE sendSem #-}

420 -- use as a trivial semiphore

421 sendSem :: MVar ()

422 sendSem = unsafePerformIO $ newMVar ()

423 -- end local

424

425

426 -- * Unique name supply code

427

428 -- Use the single threaded version

429

430 initUniq :: IO ()

431 initUniq = do

432 u <- readIORef uniq

433 when (u/=1) $ hPutStrLn stderr

434 "Warning[Debug.Observe]: reinitializing event counter (may lead to invalid event log\n\

435 \ if 'runO'/'printO' encounters already partially observed structures)"

436 writeIORef uniq 1

437

438 getUniq :: IO Int

439 getUniq

440 = do { takeMVar uniqSem

441 ; n <- readIORef uniq

442 ; writeIORef uniq $! (n + 1)

443 ; putMVar uniqSem ()

444 ; return n

445 }

446

447 peepUniq :: IO Int

448 peepUniq = readIORef uniq

449

450 -- locals

451 {-# NOINLINE uniq #-}

452 uniq :: IORef Int

453 uniq = unsafePerformIO $ newIORef 1

454

455 {-# NOINLINE uniqSem #-}

456 uniqSem :: MVar ()

457 uniqSem = unsafePerformIO $ newMVar ()

458

459 -- * Global, initializers, etc

460

461 openObserveGlobal :: IO ()

462 openObserveGlobal =

463 do { initUniq

464 ; startEventStream

465 }

466

467 closeObserveGlobal :: IO [Event]

468 closeObserveGlobal =

469 do { evs <- endEventStream

470 ; putStrLn ""

471 ; return evs

472 }

473

474 -- * The CDS and converting functions

475

476 data CDS = CDSNamed String CDSSet

477 | CDSCons Int String [CDSSet]

478 | CDSFun Int CDSSet CDSSet

479 | CDSEntered Int

480 deriving (Show,Eq,Ord)

481

482 type CDSSet = [CDS]

483

484

485 eventsToCDS :: [Event] -> CDSSet

486 eventsToCDS pairs = getChild 0 0

487 where

488 res = (!) out_arr

489

490 bnds = (0, length pairs)

491

492 mid_arr :: Array Int [(Int,CDS)]

493 mid_arr = accumArray (flip (:)) [] bnds

494 [ (pnode,(pport,res node))

495 | (Event node (Parent pnode pport) _) <- pairs

496 ]

497

498 out_arr = array bnds -- never uses 0 index

499 [ (node,getNode'' node change)

500 | (Event node _ change) <- pairs

501 ]

502

503 getNode'' :: Int -> Change -> CDS

504 getNode'' node change =

505 case change of

506 (Observe str) -> CDSNamed str (getChild node 0)

507 (Enter) -> CDSEntered node

508 (Fun) -> CDSFun node (getChild node 0) (getChild node 1)

509 (Cons portc cons)

510 -> CDSCons node cons

511 [ getChild node n | n <- [0..(portc-1)]]

512

513 getChild :: Int -> Int -> CDSSet

514 getChild pnode pport =

515 [ content

516 | (pport',content) <- (!) mid_arr pnode

517 , pport == pport'

518 ]

519

520 render :: Int -> Bool -> CDS -> DOC

521 render prec par (CDSCons _ ":" [cds1,cds2]) =

522 if par && not needParen

523 then doc -- dont use paren (..) because we dont want a grp here!

524 else paren needParen doc

525 where

526 doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>

527 renderSet' 4 True cds2

528 needParen = prec > 4

529 render prec par (CDSCons _ "," cdss) | length cdss > 0 =

530 nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)

531 (map renderSet cdss) <>

532 text ")")

533 render prec par (CDSCons _ name cdss) =

534 paren (length cdss > 0 && prec /= 0)

535 (nest 2

536 (text name <> foldr (<>) nil

537 [ sep <> renderSet' 10 False cds

538 | cds <- cdss

539 ]

540 )

541 )

542

543 -- renderSet handles the various styles of CDSSet.

544

545 renderSet :: CDSSet -> DOC

546 renderSet = renderSet' 0 False

547

548 renderSet' :: Int -> Bool -> CDSSet -> DOC

549 renderSet' _ _ [] = text "_"

550 renderSet' prec par [cons@(CDSCons {})] = render prec par cons

551 renderSet' prec par cdss =

552 nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>

553 text ", " <> b)

554 (map renderFn pairs) <>

555 line <> text "}")

556

557 where

558 pairs = nub (sort (findFn cdss))

559 -- local nub for sorted lists

560 nub [] = []

561 nub (a:a':as) | a == a' = nub (a' : as)

562 nub (a:as) = a : nub as

563

564 renderFn :: ([CDSSet],CDSSet) -> DOC

565 renderFn (args,res)

566 = grp (nest 3

567 (text "\\ " <>

568 foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)

569 nil

570 args <> sep <>

571 text "-> " <> renderSet' 0 False res

572 )

573 )

574

575 findFn :: CDSSet -> [([CDSSet],CDSSet)]

576 findFn = foldr findFn' []

577

578 findFn' (CDSFun _ arg res) rest =

579 case findFn res of

580 [(args',res')] -> (arg : args', res') : rest

581 _ -> ([arg], res) : rest

582 findFn' other rest = ([],[other]) : rest

583

584 renderTops [] = nil

585 renderTops tops = line <> foldr (<>) nil (map renderTop tops)

586

587 renderTop :: Output -> DOC

588 renderTop (OutLabel str set extras) =

589 nest 2 (text ("-- " ++ str) <> line <>

590 renderSet set

591 <> renderTops extras) <> line

592

593 rmEntry :: CDS -> CDS

594 rmEntry (CDSNamed str set) = CDSNamed str (rmEntrySet set)

595 rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets)

596 rmEntry (CDSFun i a b) = CDSFun i (rmEntrySet a) (rmEntrySet b)

597 rmEntry (CDSEntered i) = error "found bad CDSEntered"

598

599 rmEntrySet = map rmEntry . filter noEntered

600 where

601 noEntered (CDSEntered _) = False

602 noEntered _ = True

603

604 simplifyCDS :: CDS -> CDS

605 simplifyCDS (CDSNamed str set) = CDSNamed str (simplifyCDSSet set)

606 simplifyCDS (CDSCons _ "throw"

607 [[CDSCons _ "ErrorCall" set]]

608 ) = simplifyCDS (CDSCons 0 "error" set)

609 simplifyCDS cons@(CDSCons i str sets) =

610 case spotString [cons] of

611 Just str | not (null str) -> CDSCons 0 (show str) []

612 _ -> CDSCons 0 str (map simplifyCDSSet sets)

613

614 simplifyCDS (CDSFun i a b) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b)

615 -- replace with

616 -- CDSCons i "->" [simplifyCDSSet a,simplifyCDSSet b]

617 -- for turning off the function stuff.

618

619 simplifyCDSSet = map simplifyCDS

620

621 spotString :: CDSSet -> Maybe String

622 spotString [CDSCons _ ":"

623 [[CDSCons _ str []]

624 ,rest

625 ]

626 ]

627 = do { ch <- case reads str of

628 [(ch,"")] -> return ch

629 _ -> Nothing

630 ; more <- spotString rest

631 ; return (ch : more)

632 }

633 spotString [CDSCons _ "[]" []] = return []

634 spotString other = Nothing

635

636 paren :: Bool -> DOC -> DOC

637 paren False doc = grp (nest 0 doc)

638 paren True doc = grp (nest 0 (text "(" <> nest 0 doc <> brk <> text ")"))

639

640 sp :: DOC

641 sp = text " "

642

643 data Output = OutLabel String CDSSet [Output]

644 | OutData CDS

645 deriving (Eq,Ord)

646

647

648 commonOutput :: [Output] -> [Output]

649 commonOutput = sortBy byLabel

650 where

651 byLabel (OutLabel lab _ _) (OutLabel lab' _ _) = compare lab lab'

652

653 cdssToOutput :: CDSSet -> [Output]

654 cdssToOutput = map cdsToOutput

655

656 cdsToOutput (CDSNamed name cdsset)

657 = OutLabel name res1 res2

658 where

659 res1 = [ cdss | (OutData cdss) <- res ]

660 res2 = [ out | out@(OutLabel {}) <- res ]

661 res = cdssToOutput cdsset

662 cdsToOutput cons@(CDSCons {}) = OutData cons

663 cdsToOutput fn@(CDSFun {}) = OutData fn

664

665 -- * Quickcheck stuff

666

667 -- * A Pretty Printer

668

669 -- This pretty printer is based on Wadler's pretty printer.

670

671 data DOC = NIL -- nil

672 | DOC :<> DOC -- beside

673 | NEST Int DOC

674 | TEXT String

675 | LINE -- always "\n"

676 | SEP -- " " or "\n"

677 | BREAK -- "" or "\n"

678 | DOC :<|> DOC -- choose one

679 deriving (Eq,Show)

680 data Doc = Nil

681 | Text Int String Doc

682 | Line Int Int Doc

683 deriving (Show,Eq)

684

685

686 mkText :: String -> Doc -> Doc

687 mkText s d = Text (toplen d + length s) s d

688

689 mkLine :: Int -> Doc -> Doc

690 mkLine i d = Line (toplen d + i) i d

691

692 toplen :: Doc -> Int

693 toplen Nil = 0

694 toplen (Text w s x) = w

695 toplen (Line w s x) = 0

696

697 nil = NIL

698 x <> y = x :<> y

699 nest = NEST

700 text = TEXT

701 line = LINE

702 sep = SEP

703 brk = BREAK

704

705 fold x = grp (brk <> x)

706

707 grp :: DOC -> DOC

708 grp x =

709 case flatten x of

710 Just x' -> x' :<|> x

711 Nothing -> x

712

713 flatten :: DOC -> Maybe DOC

714 flatten NIL = return NIL

715 flatten (x :<> y) =

716 do x' <- flatten x

717 y' <- flatten y

718 return (x' :<> y')

719 flatten (NEST i x) =

720 do x' <- flatten x

721 return (NEST i x')

722 flatten (TEXT s) = return (TEXT s)

723 flatten LINE = Nothing -- abort

724 flatten SEP = return (TEXT " ") -- SEP is space

725 flatten BREAK = return NIL -- BREAK is nil

726 flatten (x :<|> y) = flatten x

727

728 layout :: Doc -> String

729 layout Nil = ""

730 layout (Text _ s x) = s ++ layout x

731 layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x

732

733 best w k doc = be w k [(0,doc)]

734

735 be :: Int -> Int -> [(Int,DOC)] -> Doc

736 be w k [] = Nil

737 be w k ((i,NIL):z) = be w k z

738 be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z)

739 be w k ((i,NEST j x):z) = be w k ((k+j,x):z)

740 be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z

741 be w k ((i,LINE):z) = i `mkLine` be w i z

742 be w k ((i,SEP):z) = i `mkLine` be w i z

743 be w k ((i,BREAK):z) = i `mkLine` be w i z

744 be w k ((i,x :<|> y):z) = better w k

745 (be w k ((i,x):z))

746 (be w k ((i,y):z))

747

748 better :: Int -> Int -> Doc -> Doc -> Doc

749 better w k x y = if (w-k) >= toplen x then x else y

750

751 pretty :: Int -> DOC -> String

752 pretty w = layout . best w 0

753

754 -- * GHood connection

755

756 -- Connection to GHood graphical browser (via eventsHook).

757

758 observeEventsLog = "ObserveEvents.log"

759 call_GHood = do

760 ghood <- getDataFileName "GHood.jar"

761 let call = "java -cp \"" ++ ghood ++ "\" GHood " ++ observeEventsLog

762 hPutStrLn stderr call

763 system call

764

765 eventHook e = return () -- currently not used

766 eventsHook es =

767 do

768 connectBrowser

769 mapM_ (sendBrowser.toBrowser) (reverse es)

770 disconnectBrowser

771

772 toBrowser e =

773 show (portId e)

774 ++ " " ++ show (observeParent (parent e))

775 ++ " " ++ show (observePort (parent e))

776 ++ " " ++ (case change e of

777 { Observe s -> "Observe |" ++ s

778 ; Cons n s -> "Cons " ++ show n ++ " |" ++ s

779 ; Enter -> "Enter"

780 ; Fun -> "Fun"

781 })

782

783 global_Browser_pipe_ref = unsafePerformIO $

784 newIORef (error "not connected to GHood browser")

785

786 connectBrowser =

787 do

788 pipe <- openFile observeEventsLog WriteMode

789 writeIORef global_Browser_pipe_ref pipe

790

791 disconnectBrowser =

792 do

793 pipe <- readIORef global_Browser_pipe_ref

794 writeIORef global_Browser_pipe_ref (error "not connected to Browser")

795 hClose pipe

796 call_GHood

797

798 sendBrowser cmd =

799 do

800 pipe <- readIORef global_Browser_pipe_ref

801 hPutStrLn pipe cmd

802 hFlush pipe

803

804

805