very strange behavior (crashes!) with Dynamics

First, I apologize for the length of this message.  Unfortunately, I
cannot whittle this down to a smaller example.

I'm dealing with parse trees, whose datatype looks like:

> data AnnTree a
>     = Term    { treeTag :: PackedString, treeText :: PackedString   ,
treeAnn :: a }
>     | NonTerm { treeTag :: PackedString, treeChildren :: [AnnTree a],
treeAnn :: a }
>     deriving (Eq, Ord)

In particular, I parameterize these over a DynamicMap datatype, which
looks like:

> import Data.Dynamic
> type DynamicMap = FiniteMap String Dynamic  -- cuz TypeRep \not \in
Ord :(

This supports, for instance:

> stypeOf x = show (typeOf x)
> ttypeOf (x :: T a) = stypeOf (undefined :: a)
> 
> emptyDM :: DynamicMap
> emptyDM = emptyFM
> 
> addToDM :: Typeable a => DynamicMap -> a -> DynamicMap
> addToDM dm a = addToFM dm (stypeOf a) (toDyn a)
> 
> lookupDM :: Typeable a => DynamicMap -> Maybe a
> lookupDM dm :: Maybe a =
>     case lookupFM dm (stypeOf (undefined :: a)) of
>       Nothing -> Nothing
>       Just x  -> fromDynamic x

as well as a few other of the standard FM functions that I need.

I have a type synonym:

> type DTree = AnnTree DynamicMap

so that I can add whatever types of annotations I want to the tree.

I also provide methods of showing the trees with various annotations
shown, based on a DShow type:

> type DShow = Dynamic -> Maybe ShowS
> dshowLabel :: Typeable a => (a -> ShowS) -> DShow
> dshowLabel x d = 
>   case fromDynamic d of
>     Nothing -> Nothing
>     Just v  -> Just (shows (typeOf v) . showChar '=' . x v)
> 
> showDTreeWith :: DShow -> DTree -> ShowS
> showDTreeWith shws t =
>   showChar '(' . 
>     showString (unpackPS (treeTag t)) .
>     showChar ' ' . showAnn (treeAnn t) .
>     (if isTerm t 
>        then showString (unpackPS (treeText t))
>        else showChildren (treeChildren t)) .
>     showChar ')'
>   where
>     showChildren []   = showString "<<EMPTY>>"
>     showChildren [ch] = showDTreeWith shws ch
>     showChildren (ch:chl) = showDTreeWith shws ch . showChar ' ' .
showChildren chl
>     showAnn a = showList (foldDM showAnn' [] a)
>     showAnn' dyn acc = 
>       case shws dyn of
>         Nothing -> acc
>         Just ss -> showChar '{' . ss . showChar '}' : acc
>     showList [] = id
>     showList [x] = showChar '{' . x . showChar '}' . showChar ' '
>     showList (x:xs) = showChar '{' . x . showList' xs . showChar '}' .
showChar ' '
>     showList' [] = id
>     showList' (x:xs) = showChar ';' . x . showList' xs

Basically, what this does is it is given a DShow (which can be combined,
of course, using non-shown functions), and prints the tree with the
dynamic annotations shown in braces.  The dshowLabel function takes a
shows function and creates a DShow function based on it.

For instance, I have a coreference data type, which looks like:

> data Coref = Coref Int Int Bool (Maybe String) 
>     -- Id, ref, in-min; eventually we cannonicalize these
>     -- and we can assume id= ref, type
>          deriving (Eq, Ord, Show)

We make this an instance of Typeable so we can put it in dynamic maps:

> corefTypeCon = mkTyCon "Coref" ; corefTypeRep = mkAppTy corefTypeCon
[]
> instance Typeable Coref where typeOf _ = corefTypeRep
> {-# NOINLINE corefTypeCon #-}
> {-# NOINLINE corefTypeRep #-}

Now, we have another annotation type, Range, which specifies what subset
of the sentence a given node covers.

> data Range = Single Int
>            | Range  Int Int
> 
> instance Show Range where
>   showsPrec _ (Single i) = shows i
>   showsPrec _ (Range i j) = shows i . showChar '^' . shows j
> 
> rangeTypeCon = mkTyCon "Range" ; rangeTypeRep = mkAppTy rangeTypeCon
[]
> instance Typeable Range where typeOf _ = rangeTypeRep
> {-# NOINLINE rangeTypeCon #-}
> {-# NOINLINE rangeTypeRep #-}

And we can take a DTree and add ranges with:

> numberTree :: Int -> DTree -> (Int, DTree)
> numberTree n t@(Term _ _ _) = (n+1, addAnn t (Single n))
> numberTree n t@(NonTerm _ chl _) =
>     let (n',chl') = mapAccumL numberTree n chl
>     in  (n', addAnn (t { treeChildren = chl' }) (mkRange n (n'-1)))

The associate DShow function is:

> rangeDShow :: DShow
> rangeDShow = dshowLabel (shows :: Range -> ShowS)

Now, we parse a tree, convert it into a dtree and number it:

We do:

> (_:Right (_,tree):_) = parseFile "wsj93_005.0011.par" (unsafePerformIO
$ readFile "wsj93_005.0011.par")

now, tree is of type AnnTree ().  We can convert this to a DTree with
nothing in it by applying the mkDTree function:

> mkDTree :: Tree -> DTree
> mkDTree (Term tag txt _) = Term tag txt emptyDM
> mkDTree (NonTerm tag chl _) = NonTerm tag (map mkDTree chl) emptyDM

And the number it, by doing:

> pTree :: DTree
> pTree = snd $ numberTree 1 $ mkDTree tree

we can test showing this by:

*ReadCorefData> showDTreeWith rangeDShow pTree ""
"(TOP {{Range=1^32}} (S {{Range=1^32}} (NP-A {{Range=1^11}} (NPB
{{Range=1^4}} (NE {{Range=1^3}} (NNP {{Range=1}} Michael) (NNP
{{Range=2}} D.) (NNP {{Range=3}} Casey)) (COMMA {{Range=4}} ,)) (NP
{{Range=5^11}} (NPB {{Range=5^11}} (DT {{Range=5}} a) (JJ {{Range=6}}
top) (NE {{Range=7}} (NNP {{Range=7}} Johnson)) (CC {{Range=8}} &) (NE
{{Range=9}} (NNP {{Range=9}} Johnson)) (NN {{Range=10}} manager) (COMMA
{{Range=11}} ,)))) (VP {{Range=12^32}} (VBD {{Range=12}} moved) (PP
{{Range=13^23}} (TO {{Range=13}} to) (NP-A {{Range=14^23}} (NPB
{{Range=14^17}} (NE {{Range=14^16}} (NNP {{Range=14}} Genetic) (NNP
{{Range=15}} Therapy) (NNP {{Range=16}} Inc.)) (COMMA {{Range=17}} ,))
(NP {{Range=18^23}} (NPB {{Range=18^21}} (DT {{Range=18}} a) (JJ
{{Range=19}} small) (NN {{Range=20}} biotechnology) (NN {{Range=21}}
concern)) (ADVP {{Range=22^23}} (RB {{Range=22}} here) (COMMA
{{Range=23}} ,))))) (SG {{Range=24^32}} (VP {{Range=24^32}} (TO
{{Range=24}} to) (VP-A {{Range=25^32}} (VB {{Range=25}} become)
(NP-A_AND {{Range=26^32}} (NP {{Range=26^27}} (NPB {{Range=26^27}} (PRP$
{{Range=26}} its) (NN {{Range=27}} president))) (CC {{Range=28}} and)
(NP {{Range=29^32}} (NPB {{Range=29^32}} (NN {{Range=29}} chief) (VBG
{{Range=30}} operating) (NN {{Range=31}} officer) (PERIOD {{Range=32}}
.))))))))))"

you can take my word that this is correct :).

We can show it without the annotations by:

*ReadCorefData> showDTreeWith dshow0 pTree ""
"(TOP (S (NP-A (NPB (NE (NNP Michael) (NNP D.) (NNP Casey)) (COMMA ,))
(NP (NPB (DT a) (JJ top) (NE (NNP Johnson)) (CC &) (NE (NNP Johnson))
(NN manager) (COMMA ,)))) (VP (VBD moved) (PP (TO to) (NP-A (NPB (NE
(NNP Genetic) (NNP Therapy) (NNP Inc.)) (COMMA ,)) (NP (NPB (DT a) (JJ
small) (NN biotechnology) (NN concern)) (ADVP (RB here) (COMMA ,)))))
(SG (VP (TO to) (VP-A (VB become) (NP-A_AND (NP (NPB (PRP$ its) (NN
president))) (CC and) (NP (NPB (NN chief) (VBG operating) (NN officer)
(PERIOD .))))))))))"

now, note that we have *NOT* ever added any annotations having to do
with corefs to it.

however, we can still segfault ghci by doing:

*ReadCorefData> showDTreeWith corefDShow pTree ""
"(TOP {{Coref=Coref 1 32 
Process ghci exited abnormally with code 5

where it gets the 1 32 is beyond me :).

now, for some more fun, I can reload this module into ghci, and run it
and it works fine:

   ___         ___ _
  / _ \ /\  /\/ __(_)
 / /_\// /_/ / /  | |      GHC Interactive, version 6.0, for Haskell 98.
/ /_\\/ __  / /___| |      http://www.haskell.org/ghc/
\____/\/ /_/\____/|_|      Type :? for help.

Loading package base ... linking ... done.
Loading package lang ... linking ... done.
:   Can't find module `'
    (use -v to see a list of the files searched for)
Prelude> :load c:/home/t-hald/projects/PennUtil/ReadCorefData.hs
Skipping  Common           ( /home/t-hald/projects/Common.hs,
/home/t-hald/projects/Common.o )
Compiling NLP.Util         ( /home/t-hald/projects/NLP/Util.hs,
interpreted )
Skipping  NLP.String       ( /home/t-hald/projects/NLP/String.lhs,
/home/t-hald/projects/NLP/String.o )
Skipping  NLP.FiniteMap    ( /home/t-hald/projects/NLP/FiniteMap.hs,
/home/t-hald/projects/NLP/FiniteMap.o )
Compiling NLP.PennParser   ( /home/t-hald/projects/NLP/PennParser.hs,
interpreted )
Compiling Util.DynamicMap  ( /home/t-hald/projects/Util/DynamicMap.hs,
interpreted )
Compiling PennUtil.Util    ( /home/t-hald/projects/PennUtil/Util.hs,
interpreted )
Compiling ReadCorefData    (
c:/home/t-hald/projects/PennUtil/ReadCorefData.hs, interpreted )
Ok, modules loaded: ReadCorefData, PennUtil.Util, Util.DynamicMap,
NLP.PennParser, NLP.FiniteMap, NLP.String, NLP.Util, Common.
*ReadCorefData> showDTreeWith corefDShow pTree ""
Loading package haskell98 ... linking ... done.
"(TOP (S (NP-A (NPB (NE (NNP Michael) (NNP D.) (NNP Casey)) (COMMA ,))
(NP (NPB (DT a) (JJ top) (NE (NNP Johnson)) (CC &) (NE (NNP Johnson))
(NN manager) (COMMA ,)))) (VP (VBD moved) (PP (TO to) (NP-A (NPB (NE
(NNP Genetic) (NNP Therapy) (NNP Inc.)) (COMMA ,)) (NP (NPB (DT a) (JJ
small) (NN biotechnology) (NN concern)) (ADVP (RB here) (COMMA ,)))))
(SG (VP (TO to) (VP-A (VB become) (NP-A_AND (NP (NPB (PRP$ its) (NN
president))) (CC and) (NP (NPB (NN chief) (VBG operating) (NN officer)
(PERIOD .))))))))))"
*ReadCorefData> 

just as it shouldn't print any coref data (as it doesn't know any!), it
doesn't.

now, i insert a blank line somewhere in the source, save it, and reload
(just to force ghci to actually reload it), and:

*ReadCorefData> :r
Compiling ReadCorefData    (
c:/home/t-hald/projects/PennUtil/ReadCorefData.hs, interpreted )
Ok, modules loaded: ReadCorefData, PennUtil.Util, Util.DynamicMap,
NLP.PennParser, NLP.FiniteMap, NLP.String, NLP.Util, Common.
*ReadCorefData> showDTreeWith corefDShow pTree ""
"(TOP {{Coref=Coref 1 32 
Process ghci exited abnormally with code 5


I can do this every time :).

I should mention that NLP.FiniteMap was created by stealing the code
from Data.FiniteMap and adding a few functions I felt were missing.

I've attached all the relevant source code.  The
PennUtil/ReadCorefData.hs is the module we're trying to run.  You should
untar it into a new directory if you want to experiment with it.

Any help would really be incredibly appreciated.

Thanks!

 - Hal

--
 Hal Daume III                                   | hdaume@xxxxxxx
 "Arrest this man, he talks in maths."           | www.isi.edu/~hdaume

PennError.tar.gz
Description: PennError.tar.gz