[testing code changed
martin.hofmann@uni-bamberg.de**20081208123235] hunk ./src/Data/HypoSpace.hs 161
+
hunk ./src/Data/HypoSpace.hs 163
-revhsp1 = insert hypor14 revhsp0
+revhsp1 = insert hypor04 revhsp0
hunk ./src/Data/HypoSpace.hs 169
-
+stack_overflow = S.fromList [fragai04,fragai14] --[hypor14,hypor14]
hunk ./src/Data/Initialiser.hs 75
-
+ep = (mkVP "y1_14")
hunk ./src/Data/Initialiser.hs 91
+fragsempty = ruleFrags []
+fragsai04 = ruleFrags [fragai04]
+fragsai14 = ruleFrags [fragai04,fragai14]
+fragsai24 = ruleFrags [fragai04,fragai14,fragai24]
+fragsai34 = ruleFrags [fragai04,fragai14,fragai24,fragai34]
+fragsai44 = ruleFrags [fragai04,fragai14,fragai24,fragai34,fragai44]
+
hunk ./src/Data/Initialiser.hs 99
-hypor14 = hypo $ ruleFrags [fragai04,fragai14]
+hypor14 = hypo $ fragsai14 --ruleFrags [fragai04,fragai14]
hunk ./src/Test.lhs 1
-Hi Scott,
+I am storing the TH data types 'Exp' and 'Pat' in Maps and Sets. To quickly get rid of typechecker's complaints I defined some naive instances of Ord for Exp and Pat.
hunk ./src/Test.lhs 3
-I am using the PSQueue module, and I was puzzled by the behaviour of 'alter'.  Shouldn't it be the same behaviour than Data.Map.alter?
+Now it took me about a week to realise, that 'instance Ord Pat' causes ghc to loop. Apparently, there is a reason, why Pat and Exp are not instances of Ord. What is so bad about it?
hunk ./src/Test.lhs 5
-Following some test code:
+If Pat and Exp should not be instances of Ord, maybe a note in the source code / haddock would behelpful. On the other hand, what would argue against a lexicographic ordering ( apart that it might not be very efficient ). 
hunk ./src/Test.lhs 7
-> module Test where
-
-> import qualified Data.Map as M
-> import qualified Data.Set as S
-> import Data.List (foldl')
+ 
hunk ./src/Test.lhs 9
-> type P = (Int,[String])
-> type Ps = (S.Set P)
-> data  Foo = Foo
->     { foo :: !(M.Map Int (S.Set P))  
->     , bar :: !(M.Map String (S.Set P))
->     , baz :: !(M.Map  P Int)
->     }
->   deriving(Show)
+> {-# OPTIONS_GHC -fglasgow-exts -fth #-}
+> module Test where
+> import Language.Haskell.TH
+> import Data.Set
hunk ./src/Test.lhs 14
- alterfoo fun  hsp@(HSpace m _ _ )  = 
-    case r of
-        Just r' ->  hsp{rateHyposMap = M.alter f r' m}
-        Nothing -> hsp
-    
-alterRuleHyposMap f hs hsp@(HSpace _ m _ )  = 
-    hsp{ruleHyposMap = F.fold (M.alter f) m hs}
-    
-alterHypoRateMap f h hsp@(HSpace _ _ m )  = 
-    hsp{hypoRateMap = f h m}
-    
-> initFoo = Foo M.empty M.empty M.empty
hunk ./src/Test.lhs 15
-> changefoo :: (Maybe Ps -> Maybe Ps) -> Maybe Int -> Foo -> Foo
-> changefoo fun k f@(Foo fo _ _ ) = 
->   case k of
->       Just k' -> f{foo = M.alter fun k' fo}
->       Nothing -> f
+-------------------
+ naive Ord
+ 
+> instance Ord Exp
hunk ./src/Test.lhs 20
-> changebar :: (Maybe Ps -> Maybe Ps) -> [String] -> Foo -> Foo
-> changebar fun s f@(Foo _ br _ ) = 
->   f{bar = foldl' (flip (M.alter fun)) br s}
+> instance Ord Pat
+ 
+-------------------
+ lexicographic Ord
+ 
+ instance Ord Exp where
+     compare = ( \l r -> compare (show l) (show r) )
+     
+ instance Ord Pat where
+     compare = ( \l r -> compare (show l) (show r) )
hunk ./src/Test.lhs 31
-> changebaz :: (P -> M.Map P Int -> M.Map P Int) -> P -> Foo -> Foo
-> changebaz fun i f@(Foo _ _ bz ) = 
->   f{baz = fun i bz}
+-------------------
hunk ./src/Test.lhs 33
-> insert :: P -> Foo -> Foo
-> insert p@(i,strs) fo  =
->   changefoo (maybeInsert p) (Just i) $
->   changebar (maybeInsert p) strs $
->   changebaz (flip M.insert valueP) p $
->   fo  
->   where
->   maybeInsert e s = 
->       case s of 
->         Just s' -> return $ S.insert e s'
->         Nothing -> return $ S.singleton e  
->   valueP =  foldl' ( flip $(+).length) 0 strs
hunk ./src/Test.lhs 34
-> delete :: P -> Foo -> Foo
-> delete p@(i,strs) f@(Foo _ _ bz) = 
->   changefoo (maybeDelete p) (M.lookup p bz) $
->   changebar (maybeDelete p) strs$
->   changebaz  M.delete p $
->   f
+> mkVP s = VarP $ mkName s
+> mkVE s = VarE $ mkName s
+> rule1 = (,) [mkVP "x_14"] (mkVE "y_14")
+> rule2 = (,) [InfixP (mkVP "x1_15") '(:) (mkVP "x_16")] (InfixE (Just (mkVE "y1_15")) (ConE '(:)) (Just (mkVE "ys_16")))
+> stack_overflow = fromList [rule1,rule2]
hunk ./src/Test.lhs 40
->   where
->   maybeDelete _ Nothing = Nothing 
->   maybeDelete e (Just s) = 
->       let postDel =  S.delete e s
->       in if S.null postDel 
->          then Nothing
->          else Just postDel
+> data Foo = Foo deriving Eq 
hunk ./src/Test.lhs 42
-> changeStrings :: (String,[String]) -> Foo -> Foo
-> changeStrings (old,news) fo =
->   ins $ del fo
->   where
->   del = \f -> foldl' (flip delete) f $ affectedPs 
->   ins = \f -> foldl' (flip insert) f $ modifiedPs
->   affectedPs = case M.lookup  old (bar fo) of 
->                  Just s  -> S.toList s
->                  Nothing -> []
->   modifiedPs = map change affectedPs
->   change = (\(i,olds) -> (i, news ++ (filter (/=old) olds))) 
+> instance Ord Foo
hunk ./src/Test.lhs 44
+Then try Foo < Foo.