[clean up data constructor creation code. fix bug where constructor type arguments could get reordered
John Meacham <john@repetae.net>**20060130045339] hunk ./DataConstructors.hs 41
+import Support.CanType
hunk ./DataConstructors.hs 307
-        cs' <- mapM dc cs
-        tell $ Seq.singleton d { conChildren = Just cs' }
+        let dataCons = map makeData cs
+        tell (Seq.fromList dataCons)
+        tell $ Seq.singleton theType { conChildren = Just (map conName dataCons) }
hunk ./DataConstructors.hs 311
-        as = hsDeclArgs decl
-        name = hsDeclName decl
-        d = Constructor {
-            conName = nm,
-            conType = kind $ runIdentity (Map.lookup nm km),
-            conSlots = map tvrType ts,
-            conExpr = foldr ($) (ELit (LitCons  nm (map EVar ts) rt)) (map ELam ts),
+        -- as = hsDeclArgs decl
+        --name = hsDeclName decl
+        theTypeName = toName Name.TypeConstructor (hsDeclName decl)
+        theKind = kind $ runIdentity (Map.lookup theTypeName km)
+        (theTypeFKind,theTypeKArgs') = fromPi theKind
+        theTypeArgs = [ tvr { tvrIdent = x } | tvr  <- theTypeKArgs' | x <- [2,4..] ]
+        theTypeExpr =  (ELit (LitCons theTypeName (map EVar theTypeArgs) theTypeFKind))
+        theType = Constructor {
+            conName = theTypeName,
+            conType = theKind,
+            conSlots = map tvrType theTypeArgs,
+            conExpr = foldr ($) theTypeExpr (map ELam theTypeArgs),
hunk ./DataConstructors.hs 328
-            }
-        (rt,ts') = fromPi (conType d)
-        ts = [ tvr { tvrIdent = x } | tvr  <- ts' | x <- [2,4..] ]
-        nm = toName Name.TypeConstructor name
-        dc x = let z = dc' x in tell (Seq.singleton z) >> return (conName z)
-        dc' x = Constructor {
-            conName = nm',
-            conType =tipe $ schemeToType scheme, -- ty',
-            conSlots = map (subst . tvrType) ts,  -- XXX TODO fix this mapping
-            conExpr = foldr ($) (strictize $ ELit (LitCons  nm' (map EVar ts) rt)) (map ELam ts),
-            conInhabits = nm,
+            } where
+        makeData x = Constructor {
+            conName = dataConsName,
+            conType =foldr ($) (getType theExpr) (map ELam theTypeArgs),-- tipe $ schemeToType scheme, -- ty',
+            conSlots =  slots,
+            conExpr = theExpr,
+            conInhabits = theTypeName,
hunk ./DataConstructors.hs 340
-            strictize con = E.Subst.subst tvr { tvrIdent = -1 } Unknown $ f (zip (map isHsBangedTy args) ts) con where
+            theExpr =  foldr ($) (strictize $ ELit (LitCons dataConsName (map EVar vars) theTypeExpr)) (map ELam vars)
+            slots = map (subst . tvrType) ts -- XXX TODO fix this mapping
+            vars = [ tvr { tvrType = t } | tvr <- ts | t <- slots ]
+            strictize con = E.Subst.subst tvr { tvrIdent = -1 } Unknown $ f (zip (map isHsBangedTy args) vars) con where
hunk ./DataConstructors.hs 347
-            nm' =  toName Name.DataConstructor (hsConDeclName x)
+            dataConsName =  toName Name.DataConstructor (hsConDeclName x)
hunk ./DataConstructors.hs 349
-            (rt@(ELit (LitCons _ xs _)) ,ts') = fromPi ty'
+            (ELit (LitCons _ xs _) ,ts') = fromPi $ tipe ty
hunk ./DataConstructors.hs 351
-            ts = [ tvr {tvrIdent = x} | tvr <- ts' | x <- drop (5 + length ts') [2,4..] ]
-            ty' = tipe ty
-            --ty' = tipe $ schemeToType scheme
-            Just scheme@(Forall _ (_ :=> ty)) = Map.lookup nm' cm
+            ts = [ tvr {tvrIdent = x} | tvr <- ts' | x <- drop (5 + length theTypeArgs) [2,4..] ]
+            Just (Forall _ (_ :=> ty)) = Map.lookup dataConsName cm
hunk ./E/Pretty.hs 139
-        (EVar tvr) | expanded -> prettytvr tvr
+        --(EVar tvr) | expanded -> prettytvr tvr