[change representation of Properties to be an enumerated type, with an IntSet holding them.
John Meacham <john@repetae.net>**20061121051919] addfile ./data/props.txt
addfile ./utils/gen_props.prl
hunk ./Binary.hs 40
+   getN8List,
+   putN8List,
+
hunk ./Binary.hs 460
+-- | put length prefixed list.
+putN8List :: Binary a => BinHandle -> [a] -> IO ()
+putN8List bh xs = do
+    let len = length xs
+    when (length xs > 255) $ fail "putN8List, list is too long"
+    putWord8 bh (fromIntegral len)
+    mapM_ (put_ bh) xs
+
+-- | get length prefixed list.
+getN8List :: Binary a => BinHandle -> IO [a]
+getN8List bh = do
+    n <- getWord8 bh
+    sequence $ replicate (fromIntegral n) (get bh)
+
hunk ./E/E.hs 304
-toList :: Monad m => E -> m  [E]
-toList (ELit LitCons { litName = n, litArgs = [e,b] }) | vCons == n = toList b >>= \x -> return (e:x)
-toList (ELit LitCons { litName = n, litArgs = [] }) | vEmptyList == n = return []
-toList _ = fail "toList: not list"
+eToList :: Monad m => E -> m  [E]
+eToList (ELit LitCons { litName = n, litArgs = [e,b] }) | vCons == n = eToList b >>= \x -> return (e:x)
+eToList (ELit LitCons { litName = n, litArgs = [] }) | vEmptyList == n = return []
+eToList _ = fail "eToList: not list"
hunk ./E/E.hs 309
-toString x = toList x >>= mapM fromChar where
+toString x = eToList x >>= mapM fromChar where
hunk ./E/Program.hs 50
+intercalate x xs = concat (intersperse x xs)
hunk ./E/Program.hs 56
-programSetDs ds prog | flint && hasRepeatUnder (tvrIdent . fst) ds = error $ "programSetDs: program has redundant definitions: " ++ show (map (tvrShowName . fst) ds)
-programSetDs ds prog | flint && any even (map (tvrIdent . fst) ds) = error $ "programSetDs: trying to set non unique top level name: " ++ show (map (tvrShowName . fst) ds)
+programSetDs ds prog | flint && hasRepeatUnder (tvrIdent . fst) ds = error $ "programSetDs: program has redundant definitions: \n" ++ intercalate "\n"  (sort $ map (show . tvrShowName . fst) ds)
+programSetDs ds prog | flint && any even (map (tvrIdent . fst) ds) = error $ "programSetDs: trying to set non unique top level name: \n" ++ intercalate "\n"  (sort $ map (show . tvrShowName . fst) ds)
hunk ./E/Show.hs 136
-        f e | Just xs <- toList e = do
+        f e | Just xs <- eToList e = do
hunk ./E/Values.hs 195
-    setProperty prop tvr = tvrInfo_u (setProperty prop) tvr
-    unsetProperty prop tvr = tvrInfo_u (unsetProperty prop) tvr
-    getProperty prop tvr = getProperty prop (tvrInfo tvr)
-
-    getProperties tvr = getProperties (tvrInfo tvr)
-    setProperties [] tvr = tvr
-    setProperties props tvr = tvrInfo_u (setProperties props) tvr
+    modifyProperties f = tvrInfo_u (modifyProperties f)
+    getProperties = getProperties . tvrInfo
+    putProperties prop =  tvrInfo_u (putProperties prop)
hunk ./E/WorkerWrapper.hs 17
-import Info.Info as Info
+import qualified Info.Info as Info
hunk ./E/WorkerWrapper.hs 77
-workWrap' _dataTable tvr _e | getProperty prop_WORKER tvr || getProperty prop_WRAPPER tvr = fail "already workwrapped"
-workWrap' _dataTable tvr _e | getProperty prop_INLINE tvr || getProperty prop_SUPERINLINE tvr = fail "going to be inlined"
-workWrap' _dataTable tvr _e | getProperty prop_NOINLINE tvr  = fail "not going to be inlined"
+workWrap' _dataTable tvr _e
+    | member prop_WORKER props || member prop_WRAPPER props = fail "already workwrapped"
+    | member prop_INLINE props || member prop_SUPERINLINE props = fail "going to be inlined"
+    | member prop_NOINLINE props  = fail "not going to be inlined"
+    where props = getProperties tvr
hunk ./E/WorkerWrapper.hs 98
-    nprops = Set.toList $ getProperties tvr `Set.intersection` Set.fromList [prop_JOINPOINT, prop_ONESHOT]
+    nprops = toList $ getProperties tvr `intersection` fromList [prop_JOINPOINT, prop_ONESHOT]
hunk ./FrontEnd/Tc/Module.hs 31
+import Info.Properties
hunk ./FrontEnd/Tc/Module.hs 38
+import Util.SetLike
hunk ./FrontEnd/Tc/Module.hs 258
-    let pragmaProps = Map.fromListWith (\a b -> snub $ a ++ b ) [ (toName Name.Val x,[toAtom w]) |  HsPragmaProps _ w xs <- ds, x <- xs ]
+    let pragmaProps = Map.fromListWith mappend [ (toName Name.Val x,fromList $ readProp w) |  HsPragmaProps _ w xs <- ds, x <- xs ]
hunk ./Ho/Type.hs 20
+import Info.Types
hunk ./Ho/Type.hs 68
-    hoProps :: Map.Map Name [Atom],
+    hoProps :: Map.Map Name Properties,
hunk ./Info/Binary.hs 10
+import Util.SetLike(toList,fromDistinctAscList)
hunk ./Info/Binary.hs 55
+instance Binary Properties where
+    put_ bh props = putN8List bh (toList props)
+    get bh = fromDistinctAscList `fmap` getN8List bh
+
+instance Binary Property where
+    put_ bh prop = putByte bh $ fromIntegral $ fromEnum prop
+    get bh = (toEnum . fromIntegral) `fmap` getByte bh
+
hunk ./Info/Types.hs 2
-module Info.Types where
+module Info.Types(module Info.Types, module Info.Properties) where
hunk ./Info/Types.hs 4
+import Info.Properties
hunk ./Info/Types.hs 7
-import List
+import List hiding(insert,delete)
hunk ./Info/Types.hs 11
-import Binary
-import Info.Info as Info
-import MapBinaryInstance()
+import Util.HasSize
+import Util.SetLike
+import qualified Info.Info as Info
hunk ./Info/Types.hs 15
--- | list of properties of a function, such as specified by use pragmas or options
-newtype Properties = Properties (Set.Set Atom)
-    deriving(Typeable,Eq,Binary,Monoid)
hunk ./Info/Types.hs 25
-    showsPrec _ (Properties s) = shows (sortBy (\x y -> compare (show x) (show y)) (Set.toList s))
-
-
--- These are set by user pragmas
-prop_INLINE = toAtom "INLINE"
-prop_SUPERINLINE = toAtom "SUPERINLINE"
-prop_NOINLINE = toAtom "NOINLINE"
-prop_SRCLOC_ANNOTATE = toAtom "SRCLOC_ANNOTATE"
-prop_MULTISPECIALIZE = toAtom "MULTISPECIALIZE"
-
--- | this is set on functions which are the target of an error annotated function
-prop_SRCLOC_ANNOTATE_FUN = toAtom "_SRCLOC_ANNOTATE_FUN"
-
--- | this is an internal flag set on instance functions
-prop_INSTANCE = toAtom "_INSTANCE"
+    showsPrec _ props = shows (toList props)
hunk ./Info/Types.hs 27
--- | this is an internal flag set on class methods to eventually be filled in
-prop_METHOD = toAtom "_METHOD"
hunk ./Info/Types.hs 28
--- | whether a function is exported
-prop_EXPORTED = toAtom "_EXPORTED"
+-- | list of properties of a function, such as specified by use pragmas or options
+newtype Properties = Properties (EnumSet Property)
+    deriving(Typeable,Eq,HasSize,Monoid,SetLike,BuildSet Property,ModifySet Property,IsEmpty)
hunk ./Info/Types.hs 32
-prop_JOINPOINT = toAtom "_JOINPOINT"
-prop_WORKER = toAtom "_WORKER"
-prop_WRAPPER = toAtom "_WRAPPER"
-prop_CYCLIC = toAtom "_CYCLIC"
-prop_PLACEHOLDER = toAtom "_PLACEHOLDER"
-prop_RULEBINDER = toAtom "_RULEBINDER"
-prop_SCRUTINIZED = toAtom "_SCRUTINIZED"
-prop_SPECIALIZATION = toAtom "_SPECIALIZATION"
-prop_SUPERSPECIALIZE = toAtom "_SUPERSPECIALIZE"
-prop_UNSHARED = toAtom "_UNSHARED"
-prop_ONESHOT = toAtom "_ONESHOT"
-prop_WHNF = toAtom "_WHNF"
hunk ./Info/Types.hs 35
-    setProperty :: Atom -> a -> a
-    unsetProperty :: Atom -> a -> a
-    getProperty :: Atom -> a -> Bool
-    getProperties :: a -> Set.Set Atom
-    setProperties :: [Atom] -> a -> a
-
-    setProperty prop x = setProperties [prop] x
-    setProperties xs x = foldr setProperty x xs
-    getProperty atom x = atom `Set.member` getProperties x
+    modifyProperties :: (Properties -> Properties) -> a -> a
+    getProperties :: a -> Properties
+    putProperties :: Properties -> a -> a
hunk ./Info/Types.hs 39
-instance HasProperties Properties where
-    setProperty prop (Properties x) = Properties (Set.insert prop x)
-    unsetProperty prop (Properties x) = Properties (Set.delete prop x)
-    getProperty prop (Properties x) = Set.member prop x
+    setProperty :: Property -> a -> a
+    unsetProperty :: Property -> a -> a
+    getProperty :: Property -> a -> Bool
+    setProperties :: [Property] -> a -> a
hunk ./Info/Types.hs 44
-    getProperties (Properties x) = x
-    setProperties [] p = p
-    setProperties xs (Properties x) = Properties (x `mappend` Set.fromList xs)
+    unsetProperty prop = modifyProperties (delete prop)
+    setProperty prop = modifyProperties (insert prop)
+    setProperties xs = modifyProperties (`mappend` fromList xs)
+    getProperty atom = member atom . getProperties
hunk ./Info/Types.hs 49
+instance HasProperties Properties where
+    getProperties prop = prop
+    putProperties prop _ = prop
+    modifyProperties f = f
hunk ./Info/Types.hs 54
-instance HasProperties Info where
-    setProperty prop info = case Info.lookup info of
-        Just (Properties x) -> Info.insert (Properties $ Set.insert prop x) info
-        Nothing -> Info.insert (Properties $ Set.singleton prop) info
-    unsetProperty prop info = case Info.lookup info of
-        Just pr@(Properties x) -> case Set.delete prop x of
-                p | Set.null p -> Info.delete pr info
-                  | otherwise -> Info.insert (Properties p) info
-        Nothing -> info
-    getProperty prop info = getProperty prop (Info.fetch info :: Properties)
-
-    getProperties info = getProperties (Info.fetch info :: Properties)
-    setProperties [] info = info
-    setProperties props info = case Info.lookup info of
-        Just p@(Properties _) -> Info.insert (setProperties props p) info
-        Nothing -> Info.insert (Properties $ Set.fromList props) info
hunk ./Info/Types.hs 55
+instance HasProperties Info.Info where
+    modifyProperties f info = case Info.lookup info of
+        Just x -> Info.insert (f x) info
+        Nothing -> Info.insert (f mempty) info
+    getProperties info = case Info.lookup info of
+        Just p -> p
+        Nothing -> mempty
+    putProperties prop info = Info.insert prop info
hunk ./Info/Types.hs 64
---setProperties :: HasProperties a => [Atom] -> a -> a
---setProperties [] nfo = nfo
---setProperties (p:ps) nfo = setProperty p (setProperties ps nfo)
hunk ./Main.hs 190
+    props :: Map.Map Name Properties -> Id -> Info.Info -> Info.Info
hunk ./Main.hs 192
-        Just n -> case Map.lookup n ps of
-            Just ps ->  setProperties ps
+        Just n -> case mlookup n ps of
+            Just ps ->  modifyProperties (mappend ps)
hunk ./Main.hs 219
-reprocessHo :: Rules -> Map.Map Name [Atom] -> Ho -> Ho
+reprocessHo :: Rules -> Map.Map Name Properties -> Ho -> Ho
hunk ./Main.hs 471
+        when (miniCorePass && wws > 0) $ putErrLn "^^^ After WorkWrap"
hunk ./Main.hs 487
-                    when miniCorePass  $ printCheckName fullDataTable e''
+                    when miniCorePass  $ printCheckName' fullDataTable v e''
hunk ./Makefile 18
-BUILTSOURCES= PrimitiveOperators.hs RawFiles.hs FrontEnd/HsParser.hs FlagDump.hs FlagOpts.hs Version/Raw.hs Version/Ctx.hs Name/Prim.hs
+BUILTSOURCES= PrimitiveOperators.hs RawFiles.hs FrontEnd/HsParser.hs FlagDump.hs FlagOpts.hs Version/Raw.hs Version/Ctx.hs Name/Prim.hs Info/Properties.hs
hunk ./Makefile 130
+Info/Properties.hs: data/props.txt utils/gen_props.prl
+	perl ./utils/gen_props.prl $< > $@ || rm -f $@
+
+
hunk ./SelfTest.hs 5
+import qualified List
hunk ./SelfTest.hs 19
-import Info.Info as Info
+import qualified Info.Info as Info
hunk ./SelfTest.hs 26
+import Util.SetLike
hunk ./SelfTest.hs 31
+type Prop = Info.Types.Property
+
hunk ./SelfTest.hs 45
+    testProperties
+
hunk ./SelfTest.hs 109
+testProperties = do
+    putStrLn "Testing Properties"
+    let prop_list x xs = List.delete x xs == toList p where
+            p = unsetProperty x ((fromList xs) :: Properties)
+        prop_enum :: Prop -> Prop -> Bool
+        prop_enum x y = (fromEnum x `compare` fromEnum y) == (x `compare` y)
+    quickCheck prop_list
+    quickCheck prop_enum
hunk ./SelfTest.hs 148
-    i <- return $ insert (3 :: Int) i
+    i <- return $ Info.insert (3 :: Int) i
hunk ./SelfTest.hs 150
-    unless (Info.fetch (insert (5 :: Int) i) == ([] :: [Int])) $ fail "test failed..."
+    unless (Info.fetch (Info.insert (5 :: Int) i) == ([] :: [Int])) $ fail "test failed..."
hunk ./SelfTest.hs 163
+    print (getProperties x')
hunk ./SelfTest.hs 187
-        t = Properties (Set.singleton prop_INLINE)
+        t = (singleton prop_INLINE) `mappend` fromList [prop_WORKER,prop_SPECIALIZATION]
+        t :: Properties
hunk ./SelfTest.hs 206
-    arbitrary = oneof $ map return [ TypeConstructor .. ] -- ,  DataConstructor, ClassName, TypeVal, Val, SortName, FieldLabel, RawType]
+    arbitrary = oneof $ map return [ TypeConstructor .. ]
+
+instance Arbitrary Info.Types.Property where
+    arbitrary = oneof $ map return [ minBound .. ]
hunk ./SelfTest.hs 211
+instance Arbitrary Properties where
+    arbitrary = fromList `fmap` arbitrary
hunk ./data/props.txt 1
+# These are set by user pragmas
+INLINE
+MULTISPECIALIZE
+NOINLINE
+SRCLOC_ANNOTATE
+SUPERINLINE
+
+# these are used internaly by the compiler
+_CYCLIC
+_EXPORTED
+_INSTANCE
+_JOINPOINT
+_METHOD
+_ONESHOT
+_PLACEHOLDER
+_RULEBINDER
+_SCRUTINIZED
+_SPECIALIZATION
+_SRCLOC_ANNOTATE_FUN
+_SUPERSPECIALIZE
+_UNSHARED
+_WHNF
+_WORKER
+_WRAPPER
hunk ./utils/gen_props.prl 1
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+my @props;
+
+while(<>) {
+    s/\#.*$//;
+    next unless /\S/;
+    s/^\s*(\S*)\s*$/$1/;
+    push @props, $_;
+}
+
+print "module Info.Properties where\n\n";
+
+my @props_ = @props;
+
+map { s/^_// } @props_;
+
+print "data Property = " . join " | ",  map { "PROP_$_" } @props_; 
+    print "\n    deriving(Eq,Ord,Enum,Bounded)\n\n";
+
+print "instance Show Property where\n";
+foreach (@props) {
+    my $r = $_;
+    $r =~ s/^_//;
+    print "   show PROP_$r = \"$_\"\n";
+}
+
+print "\n\n";
+
+
+print "{-# NOINLINE readProp #-}\n";
+foreach (@props) {
+    next if /^_/;
+    print "readProp \"$_\" = return PROP_$_\n";
+}
+
+print "readProp p = fail \$ \"Invalid Property: \" ++ p\n\n";
+
+foreach (@props_) {
+    print "prop_$_ = PROP_$_\n";
+}
+
+
+