Sat Dec 6 20:08:39 WET 2008 hpacheco@di.uminho.pt
* Initial import
{
addfile ./GHood.cabal
addfile ./GHood.jar
addfile ./LICENSE
addfile ./Setup.lhs
adddir ./src
adddir ./src/Debug
addfile ./src/Debug/Observe.hs
hunk ./GHood.cabal 1
+Name: GHood
+Version: 0.0.2
+License: BSD3
+License-file: LICENSE
+Copyright:
+ Copyright (c) 2008, Hugo Pacheco
+ Copyright (c) 2004, Alcino Cunha
+ Copyright (c) 2000, Claus Reinke
+ Copyright (c) 1992-2000, Andy Gill
+Author: Claus Reinke
+Maintainer: Hugo Pacheco <hpacheco@di.uminho.pt>
+Synopsis: A graphical viewer for Hood
+Description:
+ GHood is a graphical back-end for Hood, the front-end (the Haskell interface) is precisely that of Hood. If you have been using Hood already you won't have to change your programs to switch to GHood. If you haven't used Hood before, you can employ all the nice definitions in Hood's Observe library, just as explained in the Hood documentation (see the Hood homepage at <http://www.haskell.org/hood/>).
+Homepage: http://www.cs.kent.ac.uk/people/staff/cr3/toolbox/haskell/GHood
+
+Category: Debug
+
+Data-files: GHood.jar
+
+Build-type: Simple
+Cabal-Version: >=1.2
+
+Flag splitBase
+ Description: Choose the new smaller, split-up base package.
+
+Library
+ Hs-Source-Dirs: src
+ Build-Depends: base, haskell98
+ if flag(splitBase)
+ Build-Depends: base >= 3, array >= 0.1, pretty >= 1.0
+ else
+ Build-Depends: base < 3
+ exposed-modules:
+ Debug.Observe
+ other-modules:
+ Paths_GHood
+ extensions: ScopedTypeVariables Rank2Types TypeSynonymInstances
binary ./GHood.jar
hunk ./LICENSE 1
+Copyright (c) 2008, Hugo Pacheco
+Copyright (c) 2004, Alcino Cunha
+Copyright (c) 2000, Claus Reinke
+Copyright (c) 1992-2000, Andy Gill
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * The names of contributors may not be used to endorse or promote
+ products derived from this software without specific prior
+ written permission. [_$_]
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
hunk ./Setup.lhs 1
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
hunk ./src/Debug/Observe.hs 1
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Debug.Observe
+-- Copyright : [_$_]
+-- License : BSD3
+--
+-- Maintainer : hpacheco@di.uminho.pt
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- GHood:
+-- A graphical viewer for Hood
+--
+--
+-- Created a cabal library package.
+-- Improved the search for the GHood.jar file, that is bundled with the library.
+-- Changed from Literate Haskell to plain Haskell for better haddock documentation support.
+--
+-- Hugo Pacheco, November 2008
+--
+-- Added ObserveM.
+-- Adapted imports to use GHC's hierarchical libraries.
+--
+-- Alcino Cunha, February 2004
+--
+-- Modified version of Hood/Observe.lhs to match GHood, [_$_]
+-- the Graphical Haskell Object Observation Debugger, which
+-- is distributed as a Java class file archive GHood.jar.
+-- [Apart from two new hooks, modifications are at the end]
+--
+-- Claus Reinke, December 2000
+--
+-- The file is part of the Haskell Object Observation Debugger,
+-- (HOOD) July 2000 release. Actually this is all of this version
+-- of HOOD, apart from the documentation and examples...
+--
+-- HOOD is a small post-mortem debugger for the lazy functional
+-- language Haskell. It is based on the concept of observation of
+-- intermediate data structures, rather than the more traditional
+-- stepping and variable examination paradigm used by imperative
+-- language debuggers.
+--
+-- Copyright (c) Andy Gill, 1992-2000
+
+-- All rights reserved. HOOD is distributed as free software under
+-- the license in the file "License", which available from the HOOD
+-- web page, http://www.haskell.org/hood
+
+-- This module produces CDS's, based on the observation made on Haskell
+-- objects, including base types, constructors and functions.
+--
+-----------------------------------------------------------------------------
+
+
+module Debug.Observe (
+ observe
+ , Observer(..)
+ , Observing
+ , Observable(..)
+ , runO
+ , printO
+ , putStrO
+ , ObserverM(..)
+ -- * For advanced users, that want to render their own datatypes.
+ , (<<)
+ , thunk
+ , send
+ , observeBase
+ , observeOpaque
+ , Parent(..)
+ -- * For users that want to write their own render drivers.
+ , debugO
+ , CDS(..)
+ , CDSSet
+
+ ) where
+
+import IO
+import Maybe
+import Monad
+import Array
+import List
+import System
+import Data.IORef
+import Control.Concurrent
+-- The library-dependent import
+import Paths_GHood
+-- The only non standard one we assume
+import System.IO.Unsafe
+
+infixl 9 <<
+
+-- * External start functions
+
+-- | Debugs observe ridden code.
+debugO :: IO a -> IO [CDS]
+debugO program = [_$_]
+ do { initUniq
+ ; startEventStream
+ ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"
+ ; ourCatchAllIO (do { program ; return () }) [_$_]
+ (hPutStrLn stderr . errorMsg)
+ ; events <- endEventStream
+ ; return (eventsToCDS events)
+ }
+
+-- | Runs and prints observe ridden code.
+printO :: (Show a) => a -> IO ()
+printO expr = runO (print expr)
+
+-- | Prints a string during observation.
+putStrO :: String -> IO ()
+putStrO expr = runO (putStr expr)
+
+-- | Runs observe ridden code.
+runO :: IO a -> IO ()
+runO program =
+ do { cdss <- debugO program
+ ; let cdss1 = rmEntrySet cdss
+ ; let cdss2 = simplifyCDSSet cdss1
+ ; let output1 = cdssToOutput cdss2 [_$_]
+ ; let output2 = commonOutput output1
+ ; let ptyout = pretty 80 (foldr (<>) nil (map renderTop output2))
+ ; hPutStrLn stderr ""
+ ; hPutStrLn stderr ptyout
+ }
+
+-- * Simulations
+
+-- Here we provide stubs for the functionally that is not supported
+-- by some compilers, and provide some combinators of various flavors.
+
+ourCatchAllIO :: IO a -> (() -> IO a) -> IO a
+ourCatchAllIO = const
+
+handleExc :: (Observable a) => Parent -> () -> IO a
+handleExc = undefined
+
+-- * Instances
+
+-- The Haskell Base types
+
+instance Observable Int where { observer = observeBase }
+instance Observable Bool where { observer = observeBase }
+instance Observable Integer where { observer = observeBase }
+instance Observable Float where { observer = observeBase }
+instance Observable Double where { observer = observeBase }
+instance Observable Char where { observer = observeBase }
+
+instance Observable () where { observer = observeOpaque "()" }
+
+-- | Observe a base type
+observeBase :: (Show a) => a -> Parent -> a
+observeBase lit cxt = seq lit $ send (show lit) (return lit) cxt
+-- ^ 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
+
+-- The Constructors.
+
+instance (Observable a,Observable b) => Observable (a,b) where
+ observer (a,b) = send "," (return (,) << a << b)
+
+instance (Observable a,Observable b,Observable c) => Observable (a,b,c) where
+ observer (a,b,c) = send "," (return (,,) << a << b << c)
+
+instance (Observable a,Observable b,Observable c,Observable d) [_$_]
+ => Observable (a,b,c,d) where
+ observer (a,b,c,d) = send "," (return (,,,) << a << b << c << d)
+
+instance (Observable a,Observable b,Observable c,Observable d,Observable e) [_$_]
+ => Observable (a,b,c,d,e) where
+ observer (a,b,c,d,e) = send "," (return (,,,,) << a << b << c << d << e)
+
+instance (Observable a) => Observable [a] where
+ observer (a:as) = send ":" (return (:) << a << as)
+ observer [] = send "[]" (return [])
+
+instance (Observable a) => Observable (Maybe a) where
+ observer (Just a) = send "Just" (return Just << a)
+ observer Nothing = send "Nothing" (return Nothing)
+
+instance (Observable a,Observable b) => Observable (Either a b) where
+ observer (Left a) = send "Left" (return Left << a)
+ observer (Right a) = send "Right" (return Right << a)
+
+-- Arrays.
+
+instance (Ix a,Observable a,Observable b) => Observable (Array.Array a b) where
+ observer arr = send "array" (return Array.array << Array.bounds arr [_$_]
+ << Array.assocs arr)
+[_^I_][_^I_][_^I_][_$_]
+-- IO monad.
+
+instance (Observable a) => Observable (IO a) where
+ observer fn cxt = [_$_]
+ do res <- fn
+ send "<IO>" (return return << res) cxt
+[_^I_][_$_]
+-- We treat IOError this like a base value. Cheating a bit, but if you
+-- generate an IOError with a bottom in it, your just asking for trouble.
+
+instance Observable IOError where
+ observer = observeBase
+[_^I_][_$_]
+-- Functions.
+
+instance (Observable a,Observable b) => Observable (a -> b) where
+ observer fn cxt arg = sendObserveFnPacket (
+ do arg <- thunk arg
+ thunk (fn arg)) cxt
+
+ observers = defaultFnObservers
+
+-- The Exception *datatype* (not exceptions themselves!).
+-- For now, we only display IOExceptions and calls to Error.
+
+-- * Classes and Data Defintions
+
+class Observable a where
+ {-|
+ This reveals the name of a specific constructor.
+ and gets ready to explain the sub-components.
+ We put the context second so we can do eta-reduction
+ with some of our definitions.
+ -}
+ observer :: a -> Parent -> a [_$_]
+ {-| [_$_]
+ This used used to group several observer instances together.
+ -}
+ observers :: String -> (Observer -> a) -> a
+ observers label arg = defaultObservers label arg
+
+type Observing a = a -> a
+
+-- | Contains a 'forall' typed observe (if supported).
+newtype Observer = O (forall a . (Observable a) => String -> a -> a)
+
+defaultObservers :: (Observable a) => String -> (Observer -> a) -> a
+defaultObservers label fn = 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
+ { observeParent = subnode
+ , observePort = 0
+ }))
+ }
+ ; return (observer_ (fn (O observe'))
+ (Parent
+ { observeParent = node
+ , observePort = 0
+ }))
+ }
+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
+ { observeParent = subnode
+ , observePort = 0
+ }))
+ }
+ ; return (observer_ (fn (O observe'))
+ (Parent
+ { observeParent = node
+ , observePort = 0
+ }) arg)
+ }
+[_^I_][_$_]
+-- * The ObserveM Monad
+
+-- | A simple state monad for placing numbers on sub-observations.
+newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) }
+
+instance Monad ObserverM where
+ return a = ObserverM (\ c i -> (a,i))
+ fn >>= k = ObserverM (\ c i ->
+ case runMO fn c i of
+ (r,i2) -> runMO (k r) c i2
+ )
+
+-- | thunk is for marking suspensions.
+thunk :: (Observable a) => a -> ObserverM a
+thunk a = ObserverM $ \ parent port ->
+ ( observer_ a (Parent
+ { observeParent = parent
+ , observePort = port
+ }) [_$_]
+ , port+1 )
+
+-- | the infix (<<) is a shortcut for constructor arguments.
+(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b
+fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') }
+
+-- * Observe and friends
+
+{-# NOINLINE observe #-}
+-- | Our principle function and class
+observe :: (Observable a) => String -> a -> a
+observe name a = generateContext name a [_$_]
+
+{-# NOINLINE observer_ #-}
+{-|
+ This gets called before observer, allowing us to mark
+ we are entering a, before we do case analysis on
+ our object.
+ -}
+observer_ :: (Observable a) => a -> Parent -> a [_$_]
+observer_ a context = sendEnterPacket a context
+
+-- | Parent book-keeping information.
+data Parent = Parent
+ { observeParent :: !Int -- ^ my parent
+ , observePort :: !Int -- ^ my branch number
+ } deriving Show
+root = Parent 0 0
+
+-- The functions that output the data. All are dirty.
+
+unsafeWithUniq :: (Int -> IO a) -> a
+unsafeWithUniq fn [_$_]
+ = unsafePerformIO $ do { node <- getUniq
+ ; fn node
+ }
+
+generateContext :: (Observable a) => String -> a -> a
+generateContext label orig = unsafeWithUniq $ \ node ->
+ do { sendEvent node (Parent 0 0) (Observe label)
+ ; return (observer_ orig (Parent
+ { observeParent = node
+ , observePort = 0
+ })
+ )
+ }
+
+-- | Sends a packet to the observation agent.
+send :: String -> ObserverM a -> Parent -> a
+send consLabel fn context = unsafeWithUniq $ \ node ->
+ do { let (r,portCount) = runMO fn node 0
+ ; sendEvent node context (Cons portCount consLabel)
+ ; return r
+ }
+
+sendEnterPacket :: (Observable a) => a -> Parent -> a
+sendEnterPacket r context = unsafeWithUniq $ \ node ->
+ do { sendEvent node context Enter
+ ; ourCatchAllIO (evaluate (observer r context))
+ (handleExc context)
+ }
+
+evaluate :: a -> IO a
+evaluate a = a `seq` return a
+
+sendObserveFnPacket :: ObserverM a -> Parent -> a
+sendObserveFnPacket fn context = unsafeWithUniq $ \ node ->
+ do { let (r,_) = runMO fn node 0
+ ; sendEvent node context Fun
+ ; return r
+ }
+
+-- * Event stream
+
+-- Trival output functions
+
+data Event = Event
+ { portId :: !Int
+ , parent :: !Parent
+ , change :: !Change
+ }
+ deriving Show
+
+data Change
+ = Observe !String
+ | Cons !Int !String
+ | Enter
+ | Fun
+ deriving Show
+
+startEventStream :: IO ()
+startEventStream = writeIORef events []
+
+endEventStream :: IO [Event]
+endEventStream =
+ do { es <- readIORef events
+ ; writeIORef events badEvents [_$_]
+ ; eventsHook es -- cr, use return () as default
+ ; return es
+ }
+
+sendEvent :: Int -> Parent -> Change -> IO ()
+sendEvent nodeId parent change =
+ do { nodeId `seq` parent `seq` return ()
+ ; change `seq` return ()
+ ; takeMVar sendSem
+ ; es <- readIORef events
+ ; let event = Event nodeId parent change
+ ; writeIORef events (event `seq` (event : es))
+ ; eventHook event -- cr, use return () as default
+ ; putMVar sendSem ()
+ }
+
+-- local
+events :: IORef [Event]
+events = unsafePerformIO $ newIORef badEvents
+
+badEvents :: [Event]
+badEvents = error "Bad Event Stream"
+
+{-# NOINLINE sendSem #-}
+-- use as a trivial semiphore
+sendSem :: MVar ()
+sendSem = unsafePerformIO $ newMVar ()
+-- end local
+
+
+-- * Unique name supply code
+
+-- Use the single threaded version
+
+initUniq :: IO ()
+initUniq = writeIORef uniq 1
+
+getUniq :: IO Int
+getUniq
+ = do { takeMVar uniqSem
+ ; n <- readIORef uniq
+ ; writeIORef uniq $! (n + 1)
+ ; putMVar uniqSem ()
+ ; return n
+ }
+
+peepUniq :: IO Int
+peepUniq = readIORef uniq
+
+-- locals
+{-# NOINLINE uniq #-}
+uniq :: IORef Int
+uniq = unsafePerformIO $ newIORef 1
+
+{-# NOINLINE uniqSem #-}
+uniqSem :: MVar ()
+uniqSem = unsafePerformIO $ newMVar ()
+
+-- * Global, initualizers, etc
+
+openObserveGlobal :: IO ()
+openObserveGlobal =
+ do { initUniq
+ ; startEventStream
+ }
+
+closeObserveGlobal :: IO [Event]
+closeObserveGlobal =
+ do { evs <- endEventStream
+ ; putStrLn ""
+ ; return evs
+ }
+[_^I_][_$_]
+-- * The CDS and converting functions
+
+data CDS = CDSNamed String CDSSet
+ | CDSCons Int String [CDSSet]
+ | CDSFun Int CDSSet CDSSet
+ | CDSEntered Int
+ deriving (Show,Eq,Ord)
+
+type CDSSet = [CDS]
+
+
+eventsToCDS :: [Event] -> CDSSet
+eventsToCDS pairs = getChild 0 0
+ where
+ res i = (!) out_arr i
+
+ bnds = (0, length pairs)
+
+ mid_arr :: Array Int [(Int,CDS)]
+ mid_arr = accumArray (flip (:)) [] bnds
+ [ (pnode,(pport,res node))
+ | (Event node (Parent pnode pport) _) <- pairs
+ ]
+
+ out_arr = array bnds -- never uses 0 index
+ [ (node,getNode'' node change)
+ | (Event node _ change) <- pairs
+ ]
+
+ getNode'' :: Int -> Change -> CDS
+ getNode'' node change =
+ case change of
+ (Observe str) -> CDSNamed str (getChild node 0)
+ (Enter) -> CDSEntered node
+ (Fun) -> CDSFun node (getChild node 0) (getChild node 1)
+ (Cons portc cons)
+ -> CDSCons node cons [_$_]
+ [ getChild node n | n <- [0..(portc-1)]]
+
+ getChild :: Int -> Int -> CDSSet
+ getChild pnode pport =
+ [ content
+ | (pport',content) <- (!) mid_arr pnode
+ , pport == pport'
+ ]
+
+render :: Int -> Bool -> CDS -> DOC
+render prec par (CDSCons _ ":" [cds1,cds2]) =
+ if (par && not needParen) [_$_]
+ then doc -- dont use paren (..) because we dont want a grp here!
+ else paren needParen doc
+ where
+ doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>
+ renderSet' 4 True cds2
+ needParen = prec > 4
+render prec par (CDSCons _ "," cdss) | length cdss > 0 =
+ nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)
+ (map renderSet cdss) <>
+ text ")")
+render prec par (CDSCons _ name cdss) =
+ paren (length cdss > 0 && prec /= 0)
+ (nest 2
+ (text name <> foldr (<>) nil
+ [ sep <> renderSet' 10 False cds
+ | cds <- cdss [_$_]
+ ]
+ )
+ )
+
+-- renderSet handles the various styles of CDSSet.
+
+renderSet :: CDSSet -> DOC
+renderSet = renderSet' 0 False
+
+renderSet' :: Int -> Bool -> CDSSet -> DOC
+renderSet' _ _ [] = text "_"
+renderSet' prec par [cons@(CDSCons {})] = render prec par cons
+renderSet' prec par cdss = [_$_]
+ nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>
+ text ", " <> b)
+ (map renderFn pairs) <>
+ line <> text "}")
+
+ where
+ pairs = nub (sort (findFn cdss))
+ -- local nub for sorted lists
+ nub [] = []
+ nub (a:a':as) | a == a' = nub (a' : as)
+ nub (a:as) = a : nub as
+
+renderFn :: ([CDSSet],CDSSet) -> DOC
+renderFn (args,res) [_$_]
+ = grp (nest 3 [_$_]
+ (text "\\ " <>
+ foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)
+ nil
+ args <> sep <>
+ text "-> " <> renderSet' 0 False res
+ )
+ )
+
+findFn :: CDSSet -> [([CDSSet],CDSSet)]
+findFn = foldr findFn' []
+
+findFn' (CDSFun _ arg res) rest =
+ case findFn res of
+ [(args',res')] -> (arg : args', res') : rest
+ _ -> ([arg], res) : rest
+findFn' other rest = ([],[other]) : rest
+
+renderTops [] = nil
+renderTops tops = line <> foldr (<>) nil (map renderTop tops)
+
+renderTop :: Output -> DOC
+renderTop (OutLabel str set extras) =
+ nest 2 (text ("-- " ++ str) <> line <>
+ renderSet set
+ <> renderTops extras) <> line
+
+rmEntry :: CDS -> CDS
+rmEntry (CDSNamed str set) = CDSNamed str (rmEntrySet set)
+rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets)
+rmEntry (CDSFun i a b) = CDSFun i (rmEntrySet a) (rmEntrySet b)
+rmEntry (CDSEntered i) = error "found bad CDSEntered"
+
+rmEntrySet = map rmEntry . filter noEntered
+ where
+ noEntered (CDSEntered _) = False
+ noEntered _ = True
+
+simplifyCDS :: CDS -> CDS
+simplifyCDS (CDSNamed str set) = CDSNamed str (simplifyCDSSet set)
+simplifyCDS (CDSCons _ "throw" [_$_]
+ [[CDSCons _ "ErrorCall" set]]
+ ) = simplifyCDS (CDSCons 0 "error" set)
+simplifyCDS cons@(CDSCons i str sets) = [_$_]
+ case spotString [cons] of
+ Just str | not (null str) -> CDSCons 0 (show str) []
+ _ -> CDSCons 0 str (map simplifyCDSSet sets)
+
+simplifyCDS (CDSFun i a b) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b)
+ -- replace with [_$_]
+ -- CDSCons i "->" [simplifyCDSSet a,simplifyCDSSet b]
+ -- for turning off the function stuff.
+
+simplifyCDSSet = map simplifyCDS [_$_]
+
+spotString :: CDSSet -> Maybe String
+spotString [CDSCons _ ":"
+ [[CDSCons _ str []]
+ ,rest
+ ]
+ ] [_$_]
+ = do { ch <- case reads str of
+ [(ch,"")] -> return ch
+ _ -> Nothing
+ ; more <- spotString rest
+ ; return (ch : more)
+ }
+spotString [CDSCons _ "[]" []] = return []
+spotString other = Nothing
+
+paren :: Bool -> DOC -> DOC
+paren False doc = grp (nest 0 doc)
+paren True doc = grp (nest 0 (text "(" <> nest 0 doc <> brk <> text ")"))
+
+sp :: DOC
+sp = text " "
+
+data Output = OutLabel String CDSSet [Output]
+ | OutData CDS
+ deriving (Eq,Ord)
+
+
+commonOutput :: [Output] -> [Output]
+commonOutput = sortBy byLabel
+ where
+ byLabel (OutLabel lab _ _) (OutLabel lab' _ _) = compare lab lab'
+
+cdssToOutput :: CDSSet -> [Output]
+cdssToOutput = map cdsToOutput
+
+cdsToOutput (CDSNamed name cdsset)
+ = OutLabel name res1 res2
+ where
+ res1 = [ cdss | (OutData cdss) <- res ]
+ res2 = [ out | out@(OutLabel {}) <- res ]
+ res = cdssToOutput cdsset
+cdsToOutput cons@(CDSCons {}) = OutData cons
+cdsToOutput fn@(CDSFun {}) = OutData fn
+
+-- * Quickcheck stuff
+
+-- * A Pretty Printer
+
+-- This pretty printer is based on Wadler's pretty printer.
+
+data DOC = NIL -- nil[_^I_] [_$_]
+ | DOC :<> DOC -- beside [_$_]
+ | NEST Int DOC
+ | TEXT String
+ | LINE -- always "\n"
+ | SEP -- " " or "\n"
+ | BREAK -- "" or "\n"
+ | DOC :<|> DOC -- choose one
+ deriving (Eq,Show)
+data Doc = Nil
+ | Text Int String Doc
+ | Line Int Int Doc
+ deriving (Show,Eq)
+
+
+mkText :: String -> Doc -> Doc
+mkText s d = Text (toplen d + length s) s d
+
+mkLine :: Int -> Doc -> Doc
+mkLine i d = Line (toplen d + i) i d
+
+toplen :: Doc -> Int
+toplen Nil = 0
+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
+
+fold x = grp (brk <> x)
+
+grp :: DOC -> DOC
+grp x = [_$_]
+ case flatten x of
+ Just x' -> x' :<|> x
+ Nothing -> x
+
+flatten :: DOC -> Maybe DOC
+flatten NIL = return NIL
+flatten (x :<> y) = [_$_]
+ do x' <- flatten x
+ y' <- flatten y
+ return (x' :<> y')
+flatten (NEST i x) = [_$_]
+ do x' <- flatten x
+ return (NEST i x')
+flatten (TEXT s) = return (TEXT s)
+flatten LINE = Nothing -- abort
+flatten SEP = return (TEXT " ") -- SEP is space
+flatten BREAK = return NIL -- BREAK is nil
+flatten (x :<|> y) = flatten x
+
+layout :: Doc -> String
+layout Nil = ""
+layout (Text _ s x) = s ++ layout x
+layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x
+
+best w k doc = be w k [(0,doc)]
+
+be :: Int -> Int -> [(Int,DOC)] -> Doc
+be w k [] = Nil
+be w k ((i,NIL):z) = be w k z
+be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z)
+be w k ((i,NEST j x):z) = be w k ((k+j,x):z)
+be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z
+be w k ((i,LINE):z) = i `mkLine` be w i z
+be w k ((i,SEP):z) = i `mkLine` be w i z
+be w k ((i,BREAK):z) = i `mkLine` be w i z
+be w k ((i,x :<|> y):z) = better w k [_$_]
+ (be w k ((i,x):z))
+ (be w k ((i,y):z))
+
+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)
+
+-- * GHood connection
+
+-- Connection to GHood graphical browser (via eventsHook).
+
+observeEventsLog = "ObserveEvents.log"
+call_GHood = do
+ ghood <- getDataFileName "GHood.jar"
+ system $ "java -cp " ++ ghood ++ " GHood " ++ observeEventsLog
+
+eventHook e = return () -- currently not used
+eventsHook es = [_$_]
+ do
+ connectBrowser
+ mapM_ (sendBrowser.toBrowser) (reverse es)
+ 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
+ ; Enter -> "Enter"
+ ; Fun -> "Fun"
+ })
+
+global_Browser_pipe_ref = unsafePerformIO $ [_$_]
+ newIORef (error "not connected to GHood browser")
+
+connectBrowser = [_$_]
+ do
+ pipe <- openFile observeEventsLog WriteMode
+ writeIORef global_Browser_pipe_ref pipe
+
+disconnectBrowser = [_$_]
+ do
+ pipe <- readIORef global_Browser_pipe_ref
+ writeIORef global_Browser_pipe_ref (error "not connected to Browser")
+ hClose pipe
+ call_GHood
+
+sendBrowser cmd = [_$_]
+ do
+ pipe <- readIORef global_Browser_pipe_ref
+ hPutStrLn pipe cmd
+ hFlush pipe
+
+
+
}