[make enumerated types into wrappers around unboxed integers
John Meacham <john@repetae.net>**20060721005053] hunk ./DataConstructors.hs 27
-import List(sortBy,(\\))
+import List(sortBy)
hunk ./DataConstructors.hs 49
-import FrontEnd.Tc.Type
hunk ./DataConstructors.hs 95
-    conName :: Name,             -- name of constructor
-    conType :: E,                -- type of constructor
-    conExpr :: E,                -- expression which constructs this value
-    conSlots :: [E],             -- slots
+    conName     :: Name,         -- name of constructor
+    conType     :: E,            -- type of constructor
+    conExpr     :: E,            -- expression which constructs this value
+    conSlots    :: [E],          -- slots
hunk ./DataConstructors.hs 100
-    conAlias :: Bool,            -- whether this is a simple alias and has no tag of its own.
+    conAlias    :: Bool,         -- whether this is a simple alias and has no tag of its own.
hunk ./DataConstructors.hs 102
+    conVirtual  :: Maybe [Name], -- whether this is a virtual constructor that translates into an enum and its siblings
hunk ./DataConstructors.hs 140
+            conVirtual = Nothing,
hunk ./DataConstructors.hs 150
+            conVirtual = Nothing,
hunk ./DataConstructors.hs 167
+            conVirtual = Nothing,
hunk ./DataConstructors.hs 180
+                conVirtual = Nothing,
hunk ./DataConstructors.hs 184
-{-
-    tWorld__ = Constructor {
-                conName = tc_World__,
-                conType = eStar,
-                conSlots = [],
-                conDeriving = [],
-                conExpr = ELit (LitCons tc_World__ [] eStar),
-                conAlias = False,
-                conInhabits = tStar,
-                conChildren = Just [conName dWorld__]
-        }
-
-    dWorld__ = Constructor {
-                conName = dc_World__,
-                conType = conExpr tWorld__,
-                conSlots = [conType tWorldzh],
-                conDeriving = [],
-                conExpr = ELam dtvr (ELit (LitCons dc_World__ [EVar dtvr] (conExpr tWorld__))),
-                conAlias = False,
-                conInhabits = tStar,
-                conChildren = Nothing
-        }
-    dtvr = (tVr 10 (conType tWorldzh))
-    -}
-
hunk ./DataConstructors.hs 194
+            conVirtual = Nothing,
hunk ./DataConstructors.hs 207
+        conVirtual = Nothing,
hunk ./DataConstructors.hs 219
+            conVirtual = Nothing,
hunk ./DataConstructors.hs 230
+            conVirtual = Nothing,
hunk ./DataConstructors.hs 315
-followAliases dataTable l = f l 10 where
+followAliases dataTable l = f l (10::Int) where
hunk ./DataConstructors.hs 332
+    dt decl False cs@(_:_:_) | all null (map hsConDeclArgs cs) = do
+        let virtualCons'@(fc:_) = map (makeData False typeInfo) cs
+            typeInfo@(theType,_,_) = makeType decl
+            virt = Just (map conName virtualCons')
+            f (n,vc) = vc { conExpr = ELit (LitCons consName [ELit (LitInt (fromIntegral n) tIntzh)] (conType vc)), conVirtual = virt }
+            virtualCons = map f (zip [(0 :: Int) ..] virtualCons')
+            consName =  mapName (id,(++ "#")) $ toName DataConstructor (nameName (conName theType))
+            dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conSlots = [tIntzh], conExpr = ELam (tVr 12 tIntzh) (ELit (LitCons consName [EVar (tVr 12 tIntzh)] (conExpr theType))) }
+        tell (Seq.fromList virtualCons)
+        tell (Seq.singleton dataCons)
+        tell $ Seq.singleton theType { conChildren = Just [consName], conVirtual = virt }
+        return ()
+
hunk ./DataConstructors.hs 346
-        let dataCons = map makeData cs
+        let dataCons = map (makeData alias typeInfo) cs
+            typeInfo@(theType,_,_) = makeType decl
hunk ./DataConstructors.hs 350
-        where
+    makeData alias (theType,theTypeArgs,theTypeExpr) x = theData where
+        theData = Constructor {
+            conName = dataConsName,
+            conType =foldr ($) (getType theExpr) (map EPi theTypeArgs),
+            conSlots =  slots,
+            conExpr = theExpr,
+            conInhabits = conName theType,
+            conDeriving = [],
+            conVirtual = Nothing,
+            conAlias = alias,
+            conChildren = Nothing
+            }
+        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
+            f ((False,_):rs) con = f rs con
+            f ((True,var):rs) con = eStrictLet var (EVar var) con
+            f [] con = con
+        dataConsName =  toName Name.DataConstructor (hsConDeclName x)
+        args = hsConDeclArgs x
+        (ELit (LitCons _ xs _) ,ts') = fromPi $ runVarName $ do
+            flip mapM_ vs $ \tv -> do
+                newName [2,4..] () tv
+            tipe' ty
+        existentials = melems $ freeVars (map getType ts') S.\\ (freeVars xs :: IdMap TVr)
+        subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- xs | p <- [2,4..] ]
+        ts = existentials ++ [ tvr {tvrIdent = x} | tvr <- ts' | x <- drop (5 + length theTypeArgs) [2,4..] ]
+        (vs,ty) = case Map.lookup dataConsName cm of
+            Just (TForAll vs (_ :=> ty)) -> (vs,ty)
+            Just ty -> ([],ty)
+    makeType decl = (theType,theTypeArgs,theTypeExpr) where
hunk ./DataConstructors.hs 395
+            conVirtual = Nothing,
hunk ./DataConstructors.hs 397
-            } where
-        makeData x = Constructor {
-            conName = dataConsName,
-            conType =foldr ($) (getType theExpr) (map EPi theTypeArgs),
-            conSlots =  slots,
-            conExpr = theExpr,
-            conInhabits = theTypeName,
-            conDeriving = [],
-            conAlias = alias,
-            conChildren = Nothing
-            } 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
-                f ((False,_):rs) con = f rs con
-                f ((True,var):rs) con = eStrictLet var (EVar var) con
-                f [] con = con
-            dataConsName =  toName Name.DataConstructor (hsConDeclName x)
-            args = hsConDeclArgs x
-            (ELit (LitCons _ xs _) ,ts') = fromPi $ runVarName $ do
-                flip mapM_ vs $ \tv -> do
-                    newName [2,4..] () tv
-                tipe' ty
-            existentials = melems $ freeVars (map getType ts') S.\\ (freeVars xs :: IdMap TVr)
-            subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- xs | p <- [2,4..] ]
-            ts = existentials ++ [ tvr {tvrIdent = x} | tvr <- ts' | x <- drop (5 + length theTypeArgs) [2,4..] ]
-            (vs,ty) = case Map.lookup dataConsName cm of
-                Just (TForAll vs (_ :=> ty)) -> (vs,ty)
-                Just ty -> ([],ty)
-            -- =  Map.lookup dataConsName cm
-            --Just (_,_,ty) = fmap fromType $ Map.lookup dataConsName cm
+            }
hunk ./DataConstructors.hs 433
-    ans = Alt (LitCons name vs typ) e
+    ans = case conVirtual mc of
+        Nothing -> Alt (LitCons name vs typ) e
+        Just _ -> let ELit (LitCons _ [ELit (LitInt n t)] _) = conExpr mc in Alt (LitInt n t) e
hunk ./DataConstructors.hs 457
-    c  const = vcat [t,e,cs,al,ih,ch] where
+    c  const = vcat [t,e,cs,al,vt,ih,ch] where
hunk ./DataConstructors.hs 462
+        vt = case conVirtual const of
+            Nothing -> empty
+            Just ss -> text "virtual:" <+> tshow ss
hunk ./DataConstructors.hs 514
+    f e = error $ "printTypeAsHs: " ++ show e
hunk ./E/FromHs.hs 167
-{-
-convertOneVal (Forall _ (_ :=> t)) = (mp EPi ts (tipe t)) where
-    mp fn (((Tyvar _ n k _)):rs) t = fn (tVr (toId n) (kind k)) (mp fn rs t)
-    mp _ [] t = t
-    ts = ctgen t
-convertOneVal (TForAll _ (_ :=> t)) = (mp EPi ts (tipe t)) where
-    mp fn (((Tyvar _ n k _)):rs) t = fn (tVr (toId n) (kind k)) (mp fn rs t)
-    mp _ [] t = t
-    ts = ctgen t
-    -}
hunk ./E/FromHs.hs 346
+instance Monad m => DataTableMonad (Ce m) where
+    getDataTable = asks ceDataTable
+
hunk ./E/FromHs.hs 703
+                dataTable <- getDataTable
hunk ./E/FromHs.hs 705
+                    (Just patCons) = getConstructor (toName DataConstructor $ fst $ head gps) dataTable
hunk ./E/FromHs.hs 709
-                        dataTable <- asks ceDataTable
hunk ./E/FromHs.hs 720
-                return $ eCase b as err
+                case conVirtual patCons of
+                    Nothing -> return $ eCase b as err
+                    Just sibs -> do
+                        let (Just Constructor { conChildren = Just [vCons] }) = getConstructor (conInhabits patCons) dataTable
+                        [z] <- newVars [tIntzh]
+                        let err' = if length sibs <= length as then Unknown else err
+                        return $ eCase b [Alt (LitCons vCons [z] (getType b)) (eCase (EVar z) as err')] Unknown