[redo deriving of enumeration types
John Meacham <john@repetae.net>**20080324031110] addfile ./lib/base/Jhc/Inst/PrimEnum.hs
hunk ./DataConstructors.hs 462
-deriveClasses :: DataTable -> [(TVr,E)]
-deriveClasses (DataTable mp) = concatMap f (Map.elems mp) where
+deriveClasses :: IdMap Comb -> DataTable -> [(TVr,E)]
+deriveClasses cmap (DataTable mp) = concatMap f (Map.elems mp) where
hunk ./DataConstructors.hs 467
+        lupvar v = EVar (combHead comb) where
+            Just comb = mlookup (toId v) cmap
hunk ./DataConstructors.hs 471
+        Just conr = getConstructor con (DataTable mp)
+        [it@(ELit LitCons { litName = it_name })] = conSlots conr
+        Just itr = getConstructor it_name (DataTable mp)
+        DataEnum mv = conChildren itr
hunk ./DataConstructors.hs 477
-        i1 = tvr { tvrIdent = 6,  tvrType = tIntzh }
-        i2 = tvr { tvrIdent = 8,  tvrType = tIntzh }
+        i1 = tvr { tvrIdent = 6,  tvrType = it }
+        i2 = tvr { tvrIdent = 8,  tvrType = it }
hunk ./DataConstructors.hs 480
-        int1 = tvr { tvrIdent = 12, tvrType = tInt }
hunk ./DataConstructors.hs 489
-        h cl | cl == class_Enum = [{- (iv_te,ib_te), -}(iv_fe,ib_fe)] where
-            _iv_te = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName (func_toEnum sFuncNames) (nameName $ conName c), tvrType = getType ib_te }
+        h cl | cl == class_Enum = funcs where
+            funcs = [
+                (iv_te,ib_te),
+                (iv_fe,ib_fe),
+                iv v_succ succ_body,
+                iv v_pred pred_body,
+                iv v_enumFrom from_body,
+                iv v_enumFromTo fromTo_body,
+                iv v_enumFromThen fromThen_body,
+                iv v_enumFromThenTo fromThenTo_body
+                ]
+            iv_te = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName (func_toEnum sFuncNames) (nameName $ conName c), tvrType = getType ib_te }
hunk ./DataConstructors.hs 502
-            ib_te = ELam int1 (ec tInt dc_Int (EVar int1) i1 (ELit (litCons { litName = con, litArgs = [EVar i1], litType = typ })))
-            ib_fe = ELam val1 (ec typ con (EVar val1) i1 (ELit (litCons { litName = dc_Int, litArgs = [EVar i1], litType = tInt })))
-            ec typ con v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown
+            iv fname body = (setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName fname (nameName $ conName c), tvrType = getType body },body)
+            succ_body = foldl EAp (lupvar v_enum_succ) [typ, box, debox, max]
+            pred_body = foldl EAp (lupvar v_enum_pred) [typ, box, debox]
+            from_body = foldl EAp (lupvar v_enum_from) [typ, box, debox, max]
+            fromTo_body = foldl EAp (lupvar v_enum_fromTo) [typ, box, debox]
+            fromThen_body = foldl EAp (lupvar v_enum_fromThen) [typ, box, debox, max]
+            fromThenTo_body = foldl EAp (lupvar v_enum_fromThenTo) [typ, box, debox]
+
+
+            ib_te = foldl EAp (lupvar v_enum_toEnum) [typ, box, toEzh (mv - 1)]
+            ib_fe = ELam val1 (create_uintegralCast_toInt con tEnumzh (EVar val1))
+
+            max = ELit (LitInt (fromIntegral $ mv - 1) tEnumzh)
+
+            box = ELam i1 (ELit (litCons { litName = con, litArgs = [EVar i1], litType = typ }))
+            debox = ELam v1 (ec (EVar v1) i1 (EVar i1))  where
+                ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown
hunk ./DataConstructors.hs 524
-    oper_IIB op a b = EPrim (APrim (Op (Op.BinOp op Op.bits32 Op.bits32) Op.bits32) mempty) [a,b] tBoolzh
+    oper_IIB op a b = EPrim (APrim (Op (Op.BinOp op Op.bits16 Op.bits16) Op.bits16) mempty) [a,b] tBoolzh
hunk ./DerivingDrift/Drift.hs 42
-    (f class_Enum, [func_toEnum fns,func_fromEnum fns])
+    (f class_Enum, [func_toEnum fns,func_fromEnum fns] ++ map (nameName . toUnqualified) [v_enumFrom, v_succ, v_pred, v_enumFromThen, v_enumFromThenTo, v_enumFromTo])
hunk ./Main.hs 220
-        classInstances = deriveClasses dataTable
+        classInstances = deriveClasses (choCombinators cho) dataTable
hunk ./data/PrimitiveOperators-in.hs 3
-module PrimitiveOperators(primitiveInsts,constantMethods,theMethods,allCTypes) where
+module PrimitiveOperators(
+    primitiveInsts,
+    constantMethods,
+    create_uintegralCast_toInt,
+    create_uintegralCast_fromInt,
+    theMethods,
+    allCTypes
+    ) where
hunk ./data/names.txt 109
+enumFromTo           Jhc.Enum.enumFromTo
+enumFromThenTo       Jhc.Enum.enumFromThenTo
hunk ./data/names.txt 112
+succ                 Jhc.Enum.succ
+pred                 Jhc.Enum.pred
hunk ./data/names.txt 122
-
+enum_succ            Jhc.Inst.PrimEnum.enum_succ
+enum_pred            Jhc.Inst.PrimEnum.enum_pred
+enum_from            Jhc.Inst.PrimEnum.enum_from
+enum_fromTo          Jhc.Inst.PrimEnum.enum_fromTo
+enum_fromThen        Jhc.Inst.PrimEnum.enum_fromThen
+enum_fromThenTo      Jhc.Inst.PrimEnum.enum_fromThenTo
+enum_toEnum          Jhc.Inst.PrimEnum.enum_toEnum
hunk ./lib/base/Jhc/Enum.hs 5
+import Jhc.Inst.PrimEnum()
hunk ./lib/base/Jhc/Enum.hs 46
-    enumFrom x  | x `seq` True     =  x:enumFrom (increment x)
+    enumFrom x  | x `seq` True  =  enumFromTo x maxBound
+    enumFromThen c c' = [c, c' .. lastInt]
+                      where lastInt | c' < c    = minBound
+                                    | otherwise = maxBound
hunk ./lib/base/Jhc/Enum.hs 53
-    enumFromThen x y | x `seq` y `seq` True = f x where
-        z = y `minus` x
-        f x = x:f (x `plus` z)
hunk ./lib/base/Jhc/Enum.hs 71
-    enumFromTo (Char x) (Char y) = f x where
-        f x = case x `bits32UGt` y of
-            0# -> []
-            1# -> Char x:f (bits32Increment x)
-    enumFromThenTo (Char x) (Char y) (Char z) =
-        case y `bits32Sub` x of
-            inc -> let f x = case x `bits32UGte` z of
-                            1# -> Char x:f (x `bits32Add` inc)
-                            0# -> []
-             in f x
+--    enumFromTo (Char x) (Char y) = f x where
+--        f x = case x `bits32UGt` y of
+--            0# -> []
+--            1# -> Char x:f (bits32Increment x)
+--    enumFromThenTo (Char x) (Char y) (Char z) =
+--        case y `bits32Sub` x of
+--            inc -> let f x = case x `bits32UGte` z of
+--                            1# -> Char x:f (x `bits32Add` inc)
+--                            0# -> []
+--             in f x
hunk ./lib/base/Jhc/Enum.hs 88
-foreign import primitive "UGte"       bits32UGte      :: Bits32_ -> Bits32_ -> Bool__
+foreign import primitive "UGte"      bits32UGte      :: Bits32_ -> Bits32_ -> Bool__
hunk ./lib/base/Jhc/Enum.hs 91
-foreign import primitive "Add"       bits32Add      :: Bits32_ -> Bits32_ -> Bits32_
-foreign import primitive "Sub"       bits32Sub      :: Bits32_ -> Bits32_ -> Bits32_
+foreign import primitive "Add"       bits32Add       :: Bits32_ -> Bits32_ -> Bits32_
+foreign import primitive "Sub"       bits32Sub       :: Bits32_ -> Bits32_ -> Bits32_
+
hunk ./lib/base/Jhc/Inst/PrimEnum.hs 1
+{-# OPTIONS_JHC -N -fffi -funboxed-values #-}
+
+-- | helper routines for deriving(Enum) instances
+-- these routines help out the compiler when
+-- deriving enums.
+
+module Jhc.Inst.PrimEnum(enum_succ,enum_pred,enum_fromTo,enum_fromThen,enum_fromThenTo,enum_toEnum,enum_from) where
+
+
+import Jhc.Prim
+import Jhc.Int
+import Jhc.Types
+
+
+{-# INLINE enum_toEnum, enum_succ, enum_pred, enum_fromTo, enum_fromThen, enum_fromThenTo, enum_from #-}
+
+enum_toEnum :: (Enum__ -> a) -> Int__ -> Int -> a
+enum_toEnum box max int = case unboxInt int of
+    int_ -> case int_ `bits32UGt` max of
+        1# -> toEnumError
+        0# -> box (intToEnum int_)
+
+foreign import primitive "error.toEnum: out of range" toEnumError :: a
+foreign import primitive "error.succ: out of range" succError :: a
+foreign import primitive "error.pred: out of range" predError :: a
+foreign import primitive "UGt"       bits32UGt       :: Bits32_ -> Bits32_ -> Bool__
+
+enum_succ :: (Enum__ -> a) -> (a -> Enum__) -> Enum__ -> a -> a
+enum_succ box debox max e = case debox e of
+    e_ -> case e_ `enumEq` max of
+        0# -> box (enumInc e_)
+        1# -> succError
+
+enum_pred :: (Enum__ -> a) -> (a -> Enum__) -> a -> a
+enum_pred box debox e = case debox e of
+    e_ -> case e_ `enumEq` 0# of
+        0# -> box (enumDec e_)
+        1# -> predError
+
+enum_from :: (Enum__ -> a) -> (a -> Enum__) -> Enum__ -> a -> [a]
+enum_from box debox max x = case debox x of
+    x_ -> f x_ where
+        f x = case x `enumGt` max of
+            0# -> box x:f (enumInc x)
+            1# -> []
+
+enum_fromTo :: (Enum__ -> a) -> (a -> Enum__) -> a -> a -> [a]
+enum_fromTo box debox x y = case debox y of
+    y_ -> enum_from box debox y_ x
+
+enum_fromThen :: (Enum__ -> a) -> (a -> Enum__) -> Enum__ -> a -> a -> [a]
+enum_fromThen box debox max x y = case debox x of
+    x_ -> case debox y of
+        y_ -> case x_ `enumGt` y_ of
+            0# -> enum_fromThenToUp' box x_ y_ max
+            1# -> enum_fromThenToDown' box x_ y_ 0#
+
+enum_fromThenTo :: (Enum__ -> a) -> (a -> Enum__) -> a -> a -> a -> [a]
+enum_fromThenTo box debox x y z = case debox x of
+    x_ -> case debox y of
+        y_ -> case debox z of
+            z_ -> case x_ `enumGt` y_ of
+                0# -> enum_fromThenToUp' box x_ y_ z_
+                1# -> enum_fromThenToDown' box x_ y_ z_
+
+enum_fromThenToUp' :: (Enum__ -> a) -> Enum__ -> Enum__ -> Enum__ -> [a]
+enum_fromThenToUp' box x y z = case y `enumSub` x of
+            inc -> let f x = case x `enumGt` z of
+                            0# -> box x:f (x `enumAdd` inc)
+                            1# -> []
+             in f x
+
+enum_fromThenToDown' :: (Enum__ -> a) -> Enum__ -> Enum__ -> Enum__ -> [a]
+enum_fromThenToDown' box x y z = case y `enumSub` x of
+            inc -> let f x = case x `enumLt` z of
+                            0# -> box x:f (x `enumAdd` inc)
+                            1# -> []
+             in f x
+
+foreign import primitive "Eq"         enumEq  :: Enum__ -> Enum__ -> Bool__
+foreign import primitive "Gt"         enumGt  :: Enum__ -> Enum__ -> Bool__
+foreign import primitive "Lt"         enumLt  :: Enum__ -> Enum__ -> Bool__
+foreign import primitive "Gte"        enumGte :: Enum__ -> Enum__ -> Bool__
+foreign import primitive "Add"        enumAdd :: Enum__ -> Enum__ -> Enum__
+foreign import primitive "Sub"        enumSub :: Enum__ -> Enum__ -> Enum__
+foreign import primitive "increment"  enumInc :: Enum__ -> Enum__
+foreign import primitive "decrement"  enumDec :: Enum__ -> Enum__
+foreign import primitive "U2U"        intToEnum :: Int__ -> Enum__
hunk ./lib/base/Jhc/Prim.hs 23
+type Enum__ = Bits16_