[make strict constructors actually strict
John Meacham <john@repetae.net>**20060130033327] hunk ./DataConstructors.hs 4
+    constructionExpression,
hunk ./DataConstructors.hs 31
+import E.Values
hunk ./DataConstructors.hs 41
+import Support.Unparse
hunk ./DataConstructors.hs 45
-import Support.Unparse
hunk ./DataConstructors.hs 330
-            conExpr = foldr ($) (ELit (LitCons  nm' (map EVar ts) rt)) (map ELam ts),
+            conExpr = foldr ($) (strictize $ ELit (LitCons  nm' (map EVar ts) rt)) (map ELam ts),
hunk ./DataConstructors.hs 337
+            strictize con = E.Subst.subst tvr { tvrIdent = -1 } Unknown $ f (zip (map isHsBangedTy args) ts) con where
+                f ((False,_):rs) con = f rs con
+                f ((True,var):rs) con = eStrictLet var (EVar var) con
+                f [] con = con
hunk ./DataConstructors.hs 342
+            args = hsConDeclArgs x
hunk ./DataConstructors.hs 345
-            ts = [ tvr { tvrIdent =  (x)}   | tvr <- ts' | x <- drop (5 + length ts') [2,4..] ]
+            ts = [ tvr {tvrIdent = x} | tvr <- ts' | x <- drop (5 + length ts') [2,4..] ]
hunk ./DataConstructors.hs 350
+isHsBangedTy HsBangedTy {} = True
+isHsBangedTy _ = False
hunk ./DataConstructors.hs 358
+constructionExpression ::
+    DataTable -- ^ table of data constructors
+    -> Name   -- ^ name of said constructor
+    -> E      -- ^ type of eventual constructor
+    -> E      -- ^ saturated lambda calculus term
+constructionExpression wdt@(DataTable dt) n (ELit (LitCons pn xs _)) | pn == conName pc = sub (conExpr mc) where
+    Identity mc = getConstructor n wdt
+    Just pc = Map.lookup (conInhabits mc) dt
+    sub = substMap $ Map.fromDistinctAscList [ (i,sl) | sl <- xs | i <- [2,4..] ]
+constructionExpression wdt n e | Just fa <- followAlias wdt e  = constructionExpression wdt n fa
+constructionExpression _ n e = error $ "constructionExpression: error in " ++ show n ++ ": " ++ show e
hunk ./E/FromHs.hs 341
-    cExpr (HsAsPat n' (HsCon n)) =  foldr ($)  (ELit (LitCons (toName DataConstructor n) (map EVar es) rt)) (map ELam es) where -- (spec t t' (cType n))) where
+--    cExpr (HsAsPat n' (HsCon n)) =  foldr ($)  (ELit (LitCons (toName DataConstructor n) (map EVar es) rt)) (map ELam es) where -- (spec t t' (cType n))) where
+    cExpr (HsAsPat n' (HsCon n)) =  constructionExpression dataTable (toName DataConstructor n) rt where
hunk ./Grin/FromE.hs 149
-        --ev = (funcEval,(Tup [p1] :-> createEval te tags))
-        --ap = (funcApply,(createApply te tags))
hunk ./Grin/FromE.hs 152
-        --ds' = ic:ev:ap:ds
hunk ./Grin/FromE.hs 164
-    initTyEnv = mappend primTyEnv $ TyEnv $ fromList $ [ (a,(b,c)) | (_,(a,b,c)) <-  Map.toList scMap] ++ [con x| x <- Map.elems $ constructorMap dataTable]
-    con c | (ELit (LitCons _ es _),_) <- fromLam $ conExpr c = let
-            n | sortStarLike (conType c) = toAtom ('T':show (conName c))
-              | otherwise = toAtom ('C':show (conName c))
-            as = [ TyPtr TyNode |  ~(EVar tvr) <- es]
-        in  (n,(as,TyNode))
+    initTyEnv = mappend primTyEnv $ TyEnv $ fromList $ [ (a,(b,c)) | (_,(a,b,c)) <-  Map.toList scMap] ++ [con x| x <- Map.elems $ constructorMap dataTable, conType x /= eHash]
hunk ./Grin/FromE.hs 166
+    con c = (n,(as,TyNode)) where
+        n | sortStarLike (conType c) = convertName (conName c)
+          | otherwise = convertName (conName c)
+        as = [ toType (TyPtr TyNode) (getType s) |  s <- conSlots c]