[add deriving of Ix, move Bool to jhc-prim, use standalone deriving to clean up module layout
John Meacham <john@repetae.net>**20120123063809
 Ignore-this: 2443bbf598d2285a64b765f152861f32
] hunk ./lib/jhc-prim/Jhc/Prim/Bits.hs 41
+newtype Bool_ = Bool_ Bits16_
hunk ./lib/jhc-prim/Jhc/Prim/Prim.hs 12
+data Bool = False | True
+
hunk ./lib/jhc/Jhc/Inst/PrimEnum.hs 6
-
hunk ./lib/jhc/Jhc/Inst/PrimEnum.hs 10
+import Jhc.Prim.Prim
hunk ./lib/jhc/Jhc/Inst/PrimEnum.hs 21
-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__
-
hunk ./lib/jhc/Jhc/Inst/PrimEnum.hs 73
+ix_range :: (Enum__ -> a) -> (a -> Enum__) -> (a,a) -> [a]
+ix_range box debox (x,y) = enum_fromTo box debox x y
+
+ix_index :: (Enum__ -> a) -> (a -> Enum__) -> (a,a) -> a -> Int
+ix_index box debox (x,y) v = case debox v of
+    v_ -> case debox x of
+        x_ -> case debox y of
+            y_ -> case v_ `enumLte` x_ of
+                1# -> case v_ `enumLte` y_ of
+                    1# -> boxInt (enumToInt (v_ `enumSub` x_))
+                    0# -> ixIndexError
+                0# -> ixIndexError
+
+ix_inRange :: (Enum__ -> a) -> (a -> Enum__) -> (a,a) -> a -> Bool
+ix_inRange box debox (x,y) v = case debox v of
+    v_ -> case debox x of
+        x_ -> case debox y of
+            y_ -> case v_ `enumGte` x_ of
+                1# -> boxBool (v_ `enumLte` y_)
+                0# -> boxBool 0#
+
+foreign import primitive "box"        boxBool :: Bool__ -> Bool
+foreign import primitive "Add"        enumAdd :: Enum__ -> Enum__ -> Enum__
hunk ./lib/jhc/Jhc/Inst/PrimEnum.hs 98
-foreign import primitive "Lt"         enumLt  :: Enum__ -> Enum__ -> Bool__
hunk ./lib/jhc/Jhc/Inst/PrimEnum.hs 99
-foreign import primitive "Add"        enumAdd :: Enum__ -> Enum__ -> Enum__
+foreign import primitive "Lt"         enumLt  :: Enum__ -> Enum__ -> Bool__
+foreign import primitive "Lte"        enumLte :: Enum__ -> Enum__ -> Bool__
hunk ./lib/jhc/Jhc/Inst/PrimEnum.hs 102
-foreign import primitive "increment"  enumInc :: Enum__ -> Enum__
-foreign import primitive "decrement"  enumDec :: Enum__ -> Enum__
+foreign import primitive "U2U"        enumToInt :: Enum__ -> Int__
hunk ./lib/jhc/Jhc/Inst/PrimEnum.hs 104
+foreign import primitive "UGt"       bits32UGt       :: Bits32_ -> Bits32_ -> Bool__
+foreign import primitive "decrement"  enumDec :: Enum__ -> Enum__
+foreign import primitive "error.Ix.Index: out of range" ixIndexError :: a
+foreign import primitive "error.pred: out of range" predError :: a
+foreign import primitive "error.succ: out of range" succError :: a
+foreign import primitive "error.toEnum: out of range" toEnumError :: a
+foreign import primitive "increment"  enumInc :: Enum__ -> Enum__
hunk ./lib/jhc/Jhc/Order.hs 17
+import Jhc.Prim.Prim
hunk ./lib/jhc/Jhc/Order.hs 21
-data Bool = False | True
-    deriving (Eq, Ord, Bounded, Enum)
+deriving instance Eq Bool
+deriving instance Ord Bool
+deriving instance Enum Bool
hunk ./lib/jhc/Jhc/Order.hs 28
+instance Bounded Bool where
+    minBound = False
+    maxBound = True
+
hunk ./src/DataConstructors.hs 2
+    AliasType(..),
+    boxPrimitive,
+    collectDeriving,
+    conSlots,
+    constructionExpression,
hunk ./src/DataConstructors.hs 8
+    DataFamily(..),
hunk ./src/DataConstructors.hs 11
-    AliasType(..),
-    DataFamily(..),
-    Slot(..),
-    ExtTypeInfo(..),
-    extTypeInfoExtType,
-    primitiveAliases,
hunk ./src/DataConstructors.hs 12
-    constructionExpression,
hunk ./src/DataConstructors.hs 13
-    collectDeriving,
-    followAliases,
+    deriveClasses,
+    extractIO,
+    extractIO',
+    extractPrimitive,
+    ExtTypeInfo(..),
+    extTypeInfoExtType,
hunk ./src/DataConstructors.hs 20
-    tAbsurd,
-    mktBox,
-    modBox,
-    removeNewtypes,
+    followAliases,
hunk ./src/DataConstructors.hs 25
-    numberSiblings,
-    extractPrimitive,
-    boxPrimitive,
hunk ./src/DataConstructors.hs 26
-    extractIO,
-    extractIO',
+    mktBox,
+    modBox,
+    numberSiblings,
+    onlyChild,
hunk ./src/DataConstructors.hs 31
-    showDataTable,
+    primitiveAliases,
+    removeNewtypes,
hunk ./src/DataConstructors.hs 34
+    showDataTable,
+    Slot(..),
hunk ./src/DataConstructors.hs 38
+    tAbsurd,
hunk ./src/DataConstructors.hs 40
-    updateLit,
-    deriveClasses,
-    onlyChild,
-    conSlots,
-    typesCompatable
+    typesCompatable,
+    updateLit
hunk ./src/DataConstructors.hs 447
-        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
-                ]
+        h cl | Just ans <- lookup cl mthds = ans where
+            mthds = [(class_Enum,[
+                    (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
+                ]),
+                (class_Ix,[
+                    iv v_range range_body,
+--                    iv v_inRange inRange_body,
+                    iv v_index index_body
+                ])]
hunk ./src/DataConstructors.hs 472
+            range_body = foldl EAp (lupvar v_ix_range) [typ, box, debox]
+            --inRange_body = foldl EAp (lupvar v_ix_inRange) [typ, box, debox]
+            index_body = foldl EAp (lupvar v_ix_index) [typ, box, debox]
hunk ./src/DerivingDrift/Drift.hs 8
+import FrontEnd.Class
hunk ./src/DerivingDrift/Drift.hs 13
-import Name.Names
hunk ./src/DerivingDrift/Drift.hs 34
-enumDontDerive :: [(HsName,[HsName])]
-enumDontDerive = [
-    (f class_Eq, [f v_equals]),
-    (f class_Ord, [f v_geq, f v_leq, f v_lt, f v_gt]),
-    (f class_Enum, [f v_toEnum,f v_fromEnum] ++ map (nameName . toUnqualified) [v_enumFrom, v_succ, v_pred, v_enumFromThen, v_enumFromThenTo, v_enumFromTo])
-    ]  where
-        f n = nameName (toUnqualified n)
-
hunk ./src/DerivingDrift/Drift.hs 38
-        xs <- return $  map (derive isEnum d) derives -- (if isEnum then derives List.\\ enumDontDerive else derives )
+        xs <- return $  map (derive isEnum d) derives
hunk ./src/DerivingDrift/Drift.hs 56
-derive True d (toName ClassName -> wh) | Just fns <- lookup wh enumDontDerive = "" where
---derive True d (toName ClassName -> wh) | Just fns <- lookup wh enumDontDerive = inst fns where
---    dummy = "{- This is a dummy instance, it will be rewritten internally -}\n"
---    inst fns = dummy ++ "instance " ++ show wh ++ " " ++ name d ++ " where\n" ++ concat (intersperse "\n" (map f fns))
---    f n = "    " ++ g (show n) ++ " = " ++ g (show n)
---    g (c:cs) | c == '_' || c == '\'' || isAlpha c = c:cs
---    g x = "(" ++ x ++ ")"
-
+derive True d (toName ClassName -> wh) | wh `elem` enumDerivableClasses ++ map toUnqualified enumDerivableClasses = "-- generated instance  " ++ show wh ++ " " ++ name d
hunk ./src/E/FromHs.hs 116
-monadicLookup k m = case Map.lookup k m of
-    Just x  -> return x
-    Nothing -> fail "key not found"
-
hunk ./src/E/Main.hs 105
-    mapM_ print derives
hunk ./src/E/Main.hs 110
-
-    wdump FD.Derived $
+    wdump FD.Derived $ do
+        mapM_ print derives
hunk ./src/E/Main.hs 119
-
hunk ./src/E/Main.hs 122
-    ds' <- convertDecls tiData theProps (hoClassHierarchy $ hoTcInfo ho') allAssumps  fullDataTable decls
-    let ds = [ (v,e) | (v,e) <- classInstances ] ++  [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ]
- --   sequence_ [lintCheckE onerrNone fullDataTable v e | (_,v,e) <- ds ]
-
+    ds' <- convertDecls tiData theProps
+        (hoClassHierarchy $ hoTcInfo ho') allAssumps  fullDataTable decls
+    let ds = [ (v,e) | (v,e) <- classInstances ] ++
+            [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ]
hunk ./src/E/Show.hs 50
-    (tc_Boolzh,["False#","True#"]),
+    (tc_Bool_,["False#","True#"]),
hunk ./src/E/Show.hs 165
-tBoolzh = ELit litCons { litName = tc_Boolzh, litType = eHash, litAliasFor = Just tIntzh }
+tBoolzh = ELit litCons { litName = tc_Bool_, litType = eHash, litAliasFor = Just tEnumzh }
hunk ./src/E/Values.hs 261
-tBoolzh = ELit litCons { litName = tc_Boolzh, litType = eHash, litAliasFor = Just tEnumzh }
+tBoolzh = ELit litCons { litName = tc_Bool_, litType = eHash, litAliasFor = Just tEnumzh }
hunk ./src/FrontEnd/Class.hs 585
-    class_Read
+    class_Read,
+    class_Ix
hunk ./src/FrontEnd/Class.hs 595
-    class_Enum
+    class_Enum,
+    class_Ix
hunk ./src/FrontEnd/Class.hs 606
+
+-- classes that behave identically to their component when they have a single
+-- unary constructor but are not newtypes
+unaryPassDerivable :: [Name]
+unaryPassDerivable = [
+    class_Ix,
+    class_Eq,
+    class_Ord,
+    class_Bounded
+    ]
hunk ./src/FrontEnd/FrontEnd.hs 2
-    doModules',
+    doModules,
hunk ./src/FrontEnd/FrontEnd.hs 22
-doModules' :: HoTcInfo -> [HsModule] -> IO  (HoTcInfo,Tc.TiData)
-doModules' htc ms  = do
+doModules :: HoTcInfo -> [HsModule] -> IO  (HoTcInfo,Tc.TiData)
+doModules htc ms  = do
hunk ./src/FrontEnd/Tc/Module.hs 3
-import Char
+import Data.Char
hunk ./src/FrontEnd/Tc/Module.hs 34
+import Name.Names
hunk ./src/FrontEnd/Tc/Module.hs 101
--- Flag is whether it is a newtype.
hunk ./src/FrontEnd/Tc/Module.hs 102
-    = DatEmpty
-    | DatEnum [Name]
-    | DatMany Bool [(Name,Int)]
+    = DatEnum [Name]
+    | DatMany [(Name,Int)]
+    | DatNewT Name
+
+dtDataDesc :: Monad m => DataTable -> Name -> m DatDesc
+dtDataDesc dt n = maybe (fail "dtDataDesc") return $ do
+    c <- getConstructor n dt
+    let datEnum = conVirtual c >>= return . DatEnum
+        datNewT = do ErasedAlias <- return $ conAlias c; DataNormal [n] <- return $ conChildren c; return $ DatNewT n
+        datMany = do DataNormal ns <- return $ conChildren c ; return $ DatMany [ (n,-1) | n <- ns ]
+    datEnum `mplus` datNewT `mplus` datMany
hunk ./src/FrontEnd/Tc/Module.hs 119
-    f HsNewTypeDecl { hsDeclName = n, hsDeclCon = (hsConDeclName -> cn)  } = return $ DatMany True [(cn,1)]
-    f HsDataDecl { hsDeclName = n, hsDeclCons = [] } = return $ DatEmpty
-    f HsDataDecl { hsDeclName = n, hsDeclCons = cs }
+    f HsNewTypeDecl { hsDeclCon = (hsConDeclName -> cn)  } = return $ DatNewT cn
+    f HsDataDecl { hsDeclCons = cs }
hunk ./src/FrontEnd/Tc/Module.hs 122
-    f HsDataDecl { hsDeclName = n, hsDeclCons = cs } = return $ DatMany True [ (hsConDeclName c, (length . hsConDeclArgs) c) | c <- cs]
+    f HsDataDecl { hsDeclCons = cs } = return $ DatMany [ (hsConDeclName c, (length . hsConDeclArgs) c) | c <- cs]
hunk ./src/FrontEnd/Tc/Module.hs 125
-suitableForDeriving :: [HsDecl] -> (Set.Set Name,Set.Set Name)
-suitableForDeriving ds = f ds Set.empty Set.empty where
-    f [] a b = (a,b)
-    f (HsNewTypeDecl { hsDeclName = n }:ds) a b = f ds (Set.insert n a) b
-    f (HsDataDecl { hsDeclName = n, hsDeclCons = cs@(_:_:_) }:ds) a b
-        | all null $ map hsConDeclArgs cs = f ds a (Set.insert n b)
-    f (_:ds) a b = f ds a b
-
hunk ./src/FrontEnd/Tc/Module.hs 158
-
-    --wdump FD.Progress $ do
-    --    putErrLn $ "Kind inference"
hunk ./src/FrontEnd/Tc/Module.hs 178
+        --dataTable = hoDataTable htc
hunk ./src/FrontEnd/Tc/Module.hs 180
-            g r@(_,c,t) | c `elem` enumDerivableClasses, Just (DatEnum _) <- Map.lookup t dataInfo = [f r]
+            g r@(_,c,t) | c `elem` enumDerivableClasses, Just (DatEnum (_:_:_)) <- Map.lookup t dataInfo = [f r]
+                        | c `elem` enumDerivableClasses, t `elem` [tc_Bool, tc_Ordering] = [f r]
hunk ./src/FrontEnd/Tc/Module.hs 186
-
hunk ./src/FrontEnd/Tc/Module.hs 195
-
hunk ./src/FrontEnd/Tc/Module.hs 238
-    -- type inference/checking for all variables
-
hunk ./src/FrontEnd/Tc/Module.hs 242
-    --wdump FD.Progress $ do
-    --    putErrLn $ "Type inference"
hunk ./src/Ho/Build.hs 543
-                        (htc,tidata) <- doModules' ctc (map snd3 modules)
+                        (htc,tidata) <- doModules ctc (map snd3 modules)
hunk ./src/data/names.txt 15
-Bool       Jhc.Order.Bool
-Boolzh     Jhc.Order.Bool#
+Bool       Jhc.Prim.Prim.Bool
+Ordering   Jhc.Order.Ordering
+Bool_      Jhc.Prim.Bits.Bool_
hunk ./src/data/names.txt 78
-Boolzh     Jhc.Order.Bool#
+Boolzh     Jhc.Prim.Prim.Bool#
hunk ./src/data/names.txt 167
+ix_index             Jhc.Inst.PrimEnum.ix_index
+ix_inRange           Jhc.Inst.PrimEnum.ix_inRange
+ix_range             Jhc.Inst.PrimEnum.ix_range