[clean up data type code.
John Meacham <john@repetae.net>**20060216133019] hunk ./DataConstructors.hs 4
+    dataTablePrims,
hunk ./DataConstructors.hs 24
-import List(sortBy)
+import qualified Data.Set as Set
+import List(sortBy,(\\))
hunk ./DataConstructors.hs 41
+import Support.FreeVars
hunk ./DataConstructors.hs 85
-{-
-data DataType = Alias |
-    Boxed               -- ^ values are always tagged and the domain includes closures which evaluate to a term of this type as well as it's data constructors.
-    | BoxedPrimitive    -- ^ values are always tagged and the domain includes closures which evaluate to a term of this type, other values in the domain are system dependent however.
-    | UnboxedPrimitive  -- ^ values do not have a tag and the representation is system dependent
-    | Unboxed           -- ^ values do not have a tag, only a single constructor is allowed.
-    | UnboxedTagged     -- ^ values do have a tag, but closures not in the domain.
-    | Alias             -- ^ this type is isomorphic to an existing type
--}
hunk ./DataConstructors.hs 87
--- * is also a data type containing the type constructors, which are unboxed, yet tagged.
-
+-- * is also a data type containing the type constructors, which are unlifted, yet boxed.
hunk ./DataConstructors.hs 95
-    conClosures :: Bool,         -- does the domain contain closures?
hunk ./DataConstructors.hs 133
-            conClosures = False,
hunk ./DataConstructors.hs 143
-            conClosures = False,
hunk ./DataConstructors.hs 159
-            conClosures = False,
hunk ./DataConstructors.hs 170
-            conClosures = True,
hunk ./DataConstructors.hs 183
-        conClosures = False,
hunk ./DataConstructors.hs 194
-            conClosures = True,
hunk ./DataConstructors.hs 204
-            conClosures = True,
hunk ./DataConstructors.hs 254
-lookupCType dataTable e = case followAliases dataTable e of
+lookupCType dataTable e = case followAliases (mappend dataTablePrims dataTable) e of
hunk ./DataConstructors.hs 258
-lookupCType' dataTable e = case followAliases dataTable e of
+lookupCType' dataTable e = case followAliases (mappend dataTablePrims dataTable) e of
hunk ./DataConstructors.hs 292
-dataTablePrims =  Map.fromList [ (conName x,x) | x <- tabsurd:tarrow:primitiveTable ]
+dataTablePrims = DataTable $ Map.fromList [ (conName x,x) | x <- tabsurd:tarrow:primitiveTable ]
hunk ./DataConstructors.hs 296
-toDataTable km cm ds = DataTable $ Map.union dataTablePrims  (Map.fromList [ (conName x,x) | x <- ds' ])  where
+toDataTable km cm ds = DataTable (Map.mapWithKey fixupMap $ Map.fromList [ (conName x,x) | x <- ds' ])  where
+    fixupMap k _ | Just n <- getConstructor k dataTablePrims = n
+    fixupMap _ n = n
hunk ./DataConstructors.hs 318
-            conClosures = True,
hunk ./DataConstructors.hs 325
-            conType =foldr ($) (getType theExpr) (map ELam theTypeArgs),-- tipe $ schemeToType scheme, -- ty',
+            conType =foldr ($) (getType theExpr) (map EPi theTypeArgs),
hunk ./DataConstructors.hs 331
-            conClosures = False,
hunk ./DataConstructors.hs 343
+            existentials = Set.toList $ freeVars (map getType ts') Set.\\ freeVars xs
hunk ./DataConstructors.hs 345
-            ts = [ tvr {tvrIdent = x} | tvr <- ts' | x <- drop (5 + length theTypeArgs) [2,4..] ]
+            ts = existentials ++ [ tvr {tvrIdent = x} | tvr <- ts' | x <- drop (5 + length theTypeArgs) [2,4..] ]
hunk ./DataConstructors.hs 401
-    c  const = vcat [t,e,cl,cs,al,ih,ch] where
-        t = text "::" <+> ePretty conType
-        e = text "=" <+> ePretty conExpr
-        cl = text "closures:" <+> tshow conClosures
+    c  const = vcat [t,e,cs,al,ih,ch] where
+        t  = text "::" <+> ePretty conType
+        e  = text "=" <+> ePretty conExpr
hunk ./DataConstructors.hs 409
-            conName = conName, conType = conType, conExpr = conExpr, conClosures = conClosures,
-                conAlias  = conAlias, conInhabits = conInhabits, conChildren = conChildren
-                    } = const
-    xs =  [ text x <+> hang 0  (c y) | (x,y) <- ds]
+            conName = conName,
+            conType = conType,
+            conExpr = conExpr,
+            conAlias = conAlias,
+            conInhabits = conInhabits,
+            conChildren = conChildren
+            } = const
+    xs = [text x <+> hang 0 (c y) | (x,y) <- ds]
hunk ./Ho/Build.hs 457
-initialHo = mempty { hoEs = es , hoClassHierarchy = ch  }  where
+initialHo = mempty { hoEs = es , hoClassHierarchy = ch, hoDataTable = dataTablePrims  }  where