[don't automatically export instances, handle case where default instance has been dropped
John Meacham <john@repetae.net>**20060211203201] hunk ./DataConstructors.hs 366
-constructionExpression dataTable n (ELit (LitCons pn xs _)) | pn == conName pc = sub (conExpr mc) where
+constructionExpression dataTable n typ@(ELit (LitCons pn xs _))
+    | conAlias mc = ELam var (EVar var)
+    | pn == conName pc = sub (conExpr mc) where
+    var = tvr { tvrIdent = 2, tvrType = typ }
hunk ./E/FromHs.hs 4
+    convertRules,
hunk ./E/FromHs.hs 12
-    convertRules,
hunk ./E/FromHs.hs 18
-import Data.Monoid
hunk ./E/FromHs.hs 19
+import Data.Monoid
hunk ./E/FromHs.hs 21
+import Maybe
hunk ./E/FromHs.hs 203
-    method classRecord n = (methodName ,setProperty prop_METHOD (tVr ( nameToInt methodName) ty),v) where
-        methodName =  n
-        Just (deftvr@(TVr { tvrType = ty}),defe) = findName ((defaultInstanceName n))
+    method classRecord methodName = (methodName ,setProperty prop_METHOD (tVr ( nameToInt methodName) ty),v) where
+        theDefault = findName (defaultInstanceName methodName)
+        Identity (TVr {tvrType = ty},_) = findName methodName
hunk ./E/FromHs.hs 207
-        --els = eAp (EVar deftvr) (EVar tvr)
-        els = EError ("Bad: " ++ show methodName) t -- eAp (EVar deftvr) (EVar tvr)
+        els = EError ("Bad: " ++ show methodName) t
hunk ./E/FromHs.hs 212
-                | EError "Bad" _ <- defe = return $ calt $  EError ( show n ++ ": undefined at type " ++  PPrint.render (pprint  t) ) (getType els)
-                | otherwise = return $ calt $ ELetRec [(tvr,tipe t)] (EAp (EVar deftvr) (EVar tvr))
-                | ELam x e <- defe, not (isAtomic (tipe t)) = return $ calt $ substLet [(x,tipe t)] e
-                | ELam x e <- defe, isAtomic (tipe t) = return $ calt $ subst x (tipe t) e -- [(x,tipe t)] e
-                | not (isAtomic (tipe t)) = return $ calt $  (EAp (EVar deftvr) (EVar tvr))
-                | otherwise = return $ calt $ EAp (EVar deftvr) (tipe t) where -- fail "Instance does not exist" where
-            name = (instanceName n (getTypeCons t))
-            -- calt  tvr =  Alt (LitCons x [ tvr | ~(EVar tvr) <- vs ]  ct) (foldl EAp (EVar tvr) vs)
+                | Just (deftvr,defe) <- theDefault = return $ calt $ ELetRec [(tvr,tipe t)] (EAp (EVar deftvr) (EVar tvr))
+                | otherwise  = return $ calt $  EError ( show methodName ++ ": undefined at type " ++  PPrint.render (pprint t)) (getType els)
+            where
+            name = (instanceName methodName (getTypeCons t))
hunk ./E/FromHs.hs 445
-        method n = return (defaultName,tVr ( nameToInt defaultName) ty,els) where
+        method n = [(defaultName,tVr (nameToInt defaultName) ty,els) | els <- mels] where
hunk ./E/FromHs.hs 448
-            els = case [ d | d <- ds, maybeGetDeclName d == Just n] of
-                [d] | [(_,_,v)] <- cDecl d -> v
-                -- []  -> EError ((show n) ++ ": no instance or default.") ty
-                []  -> EError "Bad" ty
-                _ -> error "This shouldn't happen"
+            mels = case [ d | d <- ds, maybeGetDeclName d == Just n] of
+                [] -> []
+                (d:_) | ~[(_,_,v)] <- cDecl d -> [v]
hunk ./E/FromHs.hs 566
-    f (ELit (LitCons n [x] t)) | alias =  (f x)  where
-        alias = case getConstructor n dataTable of
-                 Just v -> conAlias v
-                 x      -> error ("deNewtype for "++show n++": "++show x)
+--    f (ELit (LitCons n [x] t)) | alias =  (f x)  where
+--        alias = case getConstructor n dataTable of
+--                 Just v -> conAlias v
+--                 x      -> error ("deNewtype for "++show n++": "++show x)
hunk ./Main.hs 181
-        ds = ds' ++ [ (runIdentity $ fromId (tvrIdent t),setProperties [prop_PLACEHOLDER,prop_EXPORTED] t, EPrim (primPrim ("Placeholder: " ++ tvrShowName t)) [] (getType t)) | t <- mnames, not $ t `Set.member` cnames]
+        ds = ds' ++ [ (runIdentity $ fromId (tvrIdent t),setProperties [prop_PLACEHOLDER] t, EPrim (primPrim ("Placeholder: " ++ tvrShowName t)) [] (getType t)) | t <- mnames, not $ t `Set.member` cnames]
hunk ./Main.hs 195
-        exports = getExports ho'
hunk ./Main.hs 204
-        --let (lc',used') = runRename usedIds lc
-        return ((n, shouldBeExported exports v,lc):ds,usedIds `mappend` used')
+        return ((n, shouldBeExported (getExports ho') v,lc):ds,usedIds `mappend` used')
hunk ./Main.hs 326
-    | tvrIdent tvr `Set.member` exports || getProperty prop_INSTANCE tvr || getProperty prop_SRCLOC_ANNOTATE_FUN tvr  = setProperty prop_EXPORTED tvr
+    | tvrIdent tvr `Set.member` exports || getProperty prop_SRCLOC_ANNOTATE_FUN tvr  = setProperty prop_EXPORTED tvr
hunk ./Main.hs 392
-            programMapBodies pruneE prog
+            prog <- programMapBodies pruneE prog
+            return $ programPruneUnreachable prog