[clean up kind inference, make it somewhat more typesafe
John Meacham <john@repetae.net>**20051203140918] hunk ./E/Pretty.hs 36
-{-
-fromHsName :: HsName -> String
-fromHsName (UnQual i) =  hsIdentString i
-fromHsName (Qual (Module "Prelude") i) =  hsIdentString i
-fromHsName (Qual (Module m) i) =  m ++ "." ++ hsIdentString i
--}
hunk ./E/Pretty.hs 63
-{-
-pName nm = \i -> case IM.lookup i m of {Just d -> d ; Nothing -> text ('x':show i)} where
-        m = IM.fromList [(i,text $  gn n) | (n,i) <- nm ]
-        gn (Left n) = fromHsName n --  $ fromAtom $ getName n
-        gn (Right n) = UC.uArrow ++ fromHsName n --  (fromAtom $ getName n)
--}
hunk ./FrontEnd/Class.hs 66
-import KindInfer
+import FrontEnd.KindInfer
hunk ./FrontEnd/Class.hs 499
-           Nothing -> error $ "instanceToTopDecls: could not find class " ++ fromHsName className ++ "in class hierarchy"
+           Nothing -> error $ "instanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"
hunk ./FrontEnd/DataConsAssump.hs 35
-import KindInfer
+import FrontEnd.KindInfer
hunk ./FrontEnd/DeclsDepends.hs 21
-import Utils                    (getDeclName, fromHsName)
+import Utils                    (getDeclName)
hunk ./FrontEnd/DeclsDepends.hs 30
-   = debugBindGroups groups (fromHsName . unRename . getDeclName)
+   = debugBindGroups groups (show . unRename . getDeclName)
hunk ./FrontEnd/FrontEnd.hs 7
+import Doc.PPrint
hunk ./FrontEnd/FrontEnd.hs 21
-import Utils
hunk ./FrontEnd/FrontEnd.hs 45
-             putStr $ PPrint.render $ pprintEnvMap (hoKinds ho)}
+             putStr $ PPrint.render $ pprint (hoKinds ho)}
hunk ./FrontEnd/KindInfer.hs 7
-module KindInfer (kiDecls,
-                  KindEnv,
-                  hsQualTypeToScheme,
-                  hsAsstToPred,
-                  kindOfClass,
-                  kindOf,
-                  aHsTypeToType
+module FrontEnd.KindInfer (
+    kiDecls,
+    KindEnv(),
+    hsQualTypeToScheme,
+    hsAsstToPred,
+    kindOfClass,
+    kindOf,
+    restrictKindEnv,
+    aHsTypeToType,
+    getConstructorKinds
+    ) where
hunk ./FrontEnd/KindInfer.hs 19
-                  ) where
-
hunk ./FrontEnd/KindInfer.hs 22
+import Data.Monoid
hunk ./FrontEnd/KindInfer.hs 27
+import Binary
hunk ./FrontEnd/KindInfer.hs 29
+import Doc.DocLike
+import Doc.PPrint
hunk ./FrontEnd/KindInfer.hs 32
-import Util.ContextMonad
+import MapBinaryInstance()
+import Name.Name
hunk ./FrontEnd/KindInfer.hs 37
+import Util.ContextMonad
+import Util.HasSize
hunk ./FrontEnd/KindInfer.hs 47
-type KindEnv = Map.Map HsName Kind
+newtype KindEnv = KindEnv (Map.Map HsName Kind)
+    deriving(Binary,Typeable,Show,HasSize,Monoid)
hunk ./FrontEnd/KindInfer.hs 81
-   apply s = Map.map (\el -> apply s el)
-   vars env = vars $ map snd $ Map.toList env
+   apply s (KindEnv m) = KindEnv $ Map.map (\el -> apply s el) m
+   vars (KindEnv env) = vars $ map snd $ Map.toList env
hunk ./FrontEnd/KindInfer.hs 85
+instance DocLike d =>  PPrint d KindEnv where
+    pprint (KindEnv m) = vcat [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m]
hunk ./FrontEnd/KindInfer.hs 144
+restrictKindEnv :: (HsName -> Bool) -> KindEnv -> KindEnv
+restrictKindEnv f (KindEnv m) = KindEnv $ Map.filterWithKey (\k _ -> f k) m
+
hunk ./FrontEnd/KindInfer.hs 169
-{- INLINE select #-}
---select :: (State -> a) -> KI a
---select selector = KI (\state -> (selector state, state))
-
-{-
-instance ContextMonad KI where
-    withContext nc (KI x)= KI (\s ->case  x (s { context = nc :context s }) of (r,s') -> (r,s' { context = context s }) )
--}
hunk ./FrontEnd/KindInfer.hs 180
-getEnv :: KI (KindEnv)
-getEnv = KI $ \e -> do
-    readIORef (kiEnv e)
+getEnv :: KI KindEnv
+getEnv = KI $ \e -> readIORef (kiEnv e)
hunk ./FrontEnd/KindInfer.hs 193
-    --modifyIORef (kiVarnum e) (+ 1)
-    --KI (\state -> let oldVarNum = varnum state
-    --                      in ((), state {varnum = oldVarNum + 1}))
hunk ./FrontEnd/KindInfer.hs 208
---(\state -> let oldSub = subst state
---                              in ((), state {subst = s `composeSubst` oldSub}))
hunk ./FrontEnd/KindInfer.hs 216
-   = do env <- getEnv
+   = do KindEnv env <- getEnv
hunk ./FrontEnd/KindInfer.hs 220
-extendEnv newEnv = KI $ \e ->
-    modifyIORef (kiEnv e) (`Map.union` newEnv)
---   = KI (\state -> let oldEnv = env state
---                   in ((), state {env = oldEnv `joinEnv` newEnv}))
+extendEnv (KindEnv newEnv) = KI $ \e ->
+    modifyIORef (kiEnv e) (\ (KindEnv env) -> KindEnv $ env `Map.union` newEnv)
hunk ./FrontEnd/KindInfer.hs 226
---   = KI (\state -> let oldEnv    = env state
---                   in ((), state {env = apply subst oldEnv}))
hunk ./FrontEnd/KindInfer.hs 234
+getConstructorKinds :: KindEnv -> Map.Map Name Kind
+getConstructorKinds (KindEnv m) = Map.fromList [ (toName TypeConstructor x,y) | (x,y)<- Map.toList m]
+
hunk ./FrontEnd/KindInfer.hs 266
-        let newEnv = Map.fromList $ [(tyconName, tyConKind)] ++ argKindVars
+        let newEnv = KindEnv $ Map.fromList $ [(tyconName, tyConKind)] ++ argKindVars
hunk ./FrontEnd/KindInfer.hs 273
-        let newEnv = Map.fromList $ (className, varKind): [(argName, varKind) | argName <- argNames]
+        let newEnv = KindEnv $ Map.fromList $ (className, varKind): [(argName, varKind) | argName <- argNames]
hunk ./FrontEnd/KindInfer.hs 287
-					  extendEnv $ Map.singleton argName varKind
+					  extendEnv $ KindEnv $ Map.singleton argName varKind
hunk ./FrontEnd/KindInfer.hs 325
-				extendEnv $ Map.singleton name varKind
+				extendEnv $ KindEnv $ Map.singleton name varKind
hunk ./FrontEnd/KindInfer.hs 495
-kindOf name env
+kindOf name (KindEnv env)
hunk ./FrontEnd/KindInfer.hs 502
-kindOfClass name env
+kindOfClass name (KindEnv env)
hunk ./FrontEnd/KindInfer.hs 561
+
hunk ./FrontEnd/Rename.hs 164
-            | otherwise = error $ "strong bad: " ++ fromHsName hsName
+            | otherwise = error $ "strong bad: " ++ show hsName
hunk ./FrontEnd/Rename.hs 167
-        mult xs@((n,sl):_) = warn sl "multiply-defined" (fromHsName n ++ " is defined multiple times: " ++ show xs )
+        mult xs@((n,sl):_) = warn sl "multiply-defined" (show n ++ " is defined multiple times: " ++ show xs )
hunk ./FrontEnd/Rename.hs 946
-                Nothing -> "Unknown name: " ++ fromHsName hsName }
+                Nothing -> "Unknown name: " ++ show hsName }
hunk ./FrontEnd/Representation.hs 163
-tyvar n k = Tyvar (fromString $ fromHsName n) n k
+tyvar n k = Tyvar (fromString $ show n) n k
hunk ./FrontEnd/TIMain.hs 39
-import Utils                    (fromHsName,
-                                 getDeclName,
+import Utils                    (getDeclName,
hunk ./FrontEnd/TIMain.hs 51
-import KindInfer(KindEnv)
+import FrontEnd.KindInfer(KindEnv)
hunk ./FrontEnd/TIMain.hs 553
-           fail $ "signature too general for " ++ fromHsName (getDeclName decl) ++ "\n Given: " ++ show sc ++ "\n Infered: " ++ show sc'
+           fail $ "signature too general for " ++ show (getDeclName decl) ++ "\n Given: " ++ show sc ++ "\n Infered: " ++ show sc'
hunk ./FrontEnd/TIMain.hs 555
-           fail $ "context too weak for "  ++ fromHsName (getDeclName decl) ++ "\nGiven: " ++ PPrint.render (pprint  sc) ++ "\nInfered: " ++ PPrint.render (pprint sc') ++"\nContext: " ++ PPrint.render (pprint  rs)
+           fail $ "context too weak for "  ++ show (getDeclName decl) ++ "\nGiven: " ++ PPrint.render (pprint  sc) ++ "\nInfered: " ++ PPrint.render (pprint sc') ++"\nContext: " ++ PPrint.render (pprint  rs)
hunk ./FrontEnd/TIModule.hs 25
-import KindInfer
+import FrontEnd.KindInfer
hunk ./FrontEnd/TIModule.hs 41
-trimEnv env = (Map.fromList [ n | n@(name,_) <- Map.toList env,  isGlobal name ])
-trimMapEnv env = (Map.fromAscList [ n | n@(name,_) <- Map.toAscList env,  isGlobal name ])
---------------------------------------------------------------------------------
+trimEnv env = Map.filterWithKey (\k _ -> isGlobal k) env -- (Map.fromList [ n | n@(name,_) <- Map.toList env,  isGlobal name ])
hunk ./FrontEnd/TIModule.hs 155
-             putStr $ PPrint.render $ pprintEnvMap kindInfo}
+             putStr $ PPrint.render $ pprint kindInfo}
hunk ./FrontEnd/TIModule.hs 247
-                (importVarEnv  )               -- type environment
+                importVarEnv                   -- type environment
hunk ./FrontEnd/TIModule.hs 255
-    let externalEnv = Map.fromList [ v | v@(x@(Qual m i) ,s) <- Map.toList localVarEnv, isGlobal x, m `elem` map modInfoName ms ]  `Map.union` noDefaultSigs
+    --let externalEnv = Map.fromList [ v | v@(x@(Qual m i) ,s) <- Map.toList localVarEnv, isGlobal x, m `elem` map modInfoName ms ]  `Map.union` noDefaultSigs
+    let externalEnv = Map.filterWithKey (\ x@(Qual m _) _ -> isGlobal x && (m `elem` map modInfoName ms)) localVarEnv `Map.union` noDefaultSigs
hunk ./FrontEnd/TIModule.hs 258
-    let externalKindEnv = Map.fromList [ v | v@(x@(Qual m i) ,s) <- Map.toList kindInfo, isGlobal x, m `elem` map modInfoName ms ]
+    --let externalKindEnv = Map.fromList [ v | v@(x@(Qual m i) ,s) <- Map.toList kindInfo, isGlobal x, m `elem` map modInfoName ms ]
+    let externalKindEnv = restrictKindEnv (\ x@(Qual m _)  -> isGlobal x && (m `elem` map modInfoName ms)) kindInfo
hunk ./FrontEnd/TIMonad.hs 50
-import KindInfer             (KindEnv)
+import FrontEnd.KindInfer             (KindEnv)
hunk ./FrontEnd/TypeSigs.hs 22
-import KindInfer        (KindEnv)
+import FrontEnd.KindInfer        (KindEnv)
hunk ./FrontEnd/TypeUtils.hs 33
-import Utils   (fromHsName)
-import KindInfer
+import FrontEnd.KindInfer
hunk ./FrontEnd/TypeUtils.hs 93
-   newQualIdent = Qual mod $ HsIdent $ fromHsName ident
+   newQualIdent = Qual mod $ HsIdent $ show ident
hunk ./FrontEnd/Utils.hs 80
-fromHsName :: HsName -> String
-fromHsName (UnQual i) = hsIdentString i
-fromHsName (Qual (Module m) i) = m ++ "." ++ (hsIdentString i)
-
-
-
-
hunk ./Ho.hs 46
-import KindInfer
+import FrontEnd.KindInfer
hunk ./Main.hs 41
+import FrontEnd.KindInfer(getConstructorKinds)
hunk ./Main.hs 161
-    let dataTable = toDataTable (Map.fromList $[ (toName TypeConstructor x,y) | (x,y)<- Map.toList (hoKinds ho')] ) (tiAllAssumptions tiData) decls
+    --let dataTable = toDataTable (Map.fromList $[ (toName TypeConstructor x,y) | (x,y)<- Map.toList (hoKinds ho')] ) (tiAllAssumptions tiData) decls
+    let dataTable = toDataTable (getConstructorKinds (hoKinds ho')) (tiAllAssumptions tiData) decls