[build associated types info inside of instances
John Meacham <john@repetae.net>**20061018094210] hunk ./FrontEnd/Class.hs 1
-{-------------------------------------------------------------------------------
-
-        Copyright:              Mark Jones and The Hatchet Team
-                                (see file Contributors)
-
-        Module:                 Class
-
-        Description:            Code for manipulating the class hierarchy and
-                                qualified types.
-
-                                The main tasks implemented by this module are:
-                                        - context reduction
-                                        - context spliting
-                                        - defaulting
-                                        - entailment of class constraints
-                                        - class hierarchy representation and
-                                          manipulation
-
-        Primary Authors:        Mark Jones, Bernie Pope
-
-        Notes:                  See the files License and License.thih
-                                for license information.
-
-                                Large parts of this module were derived from
-                                the work of Mark Jones' "Typing Haskell in
-                                Haskell", (http://www.cse.ogi.edu/~mpj/thih/)
-
--------------------------------------------------------------------------------}
-
--- TODO this, of everything desperatly needs to be rewritten the most.
-
hunk ./FrontEnd/Class.hs 14
+    makeInstanceEnvironment,
hunk ./FrontEnd/Class.hs 25
-import Text.PrettyPrint.HughesPJ as PPrint
+import Text.PrettyPrint.HughesPJ(render,Doc())
hunk ./FrontEnd/Class.hs 27
+import qualified Text.PrettyPrint.HughesPJ as PPrint
hunk ./FrontEnd/Class.hs 30
+import Doc.DocLike
hunk ./FrontEnd/Class.hs 37
-import Util.SetLike
hunk ./FrontEnd/Class.hs 44
+import Support.CanType
hunk ./FrontEnd/Class.hs 48
-import Util.HasSize
hunk ./FrontEnd/Class.hs 49
+import Util.HasSize
hunk ./FrontEnd/Class.hs 51
+import Util.SetLike
hunk ./FrontEnd/Class.hs 58
-newtype Inst = Inst {
-    instHead :: Qual Pred
-    } deriving(Typeable,Data,Eq,Ord,PPrint Doc,Show)
+data Inst = Inst {
+    instHead :: Qual Pred,
+    instAssocs :: [(Tycon,[Tyvar],Sigma)]  -- only has extra arguments, after first one
+    } deriving(Typeable,Data,Eq,Ord,Show)
hunk ./FrontEnd/Class.hs 64
-emptyInstance = Inst { instHead = error "emptyInstance" }
+instance PPrint a (Qual Pred) => PPrint a Inst where
+    pprint Inst { instHead = h, instAssocs = [] } = pprint h
+    pprint Inst { instHead = h, instAssocs = as } = pprint h <+> text "where" <$> vcat [ text "    type" <+> pprint n <+> text "_" <+> hsep (map pprint ts) <+> text "=" <+> pprint sigma  | (n,ts,sigma) <- as]
+
+
+emptyInstance = Inst { instHead = error "emptyInstance", instAssocs = [] }
hunk ./FrontEnd/Class.hs 74
+    classArgs :: [Tyvar],
hunk ./FrontEnd/Class.hs 78
-    classAssocs :: [((Name,Kind),[(Name,Kind)],Maybe Sigma)],
+    classAssocs :: [(Tycon,[Tyvar],Maybe Sigma)],
hunk ./FrontEnd/Class.hs 87
+    classArgs = [],
hunk ./FrontEnd/Class.hs 101
-    classDerives = snub $ classDerives cra ++ classDerives crb
+    classDerives = snub $ classDerives cra ++ classDerives crb,
+    classArgs = if null (classArgs cra) then classArgs crb else classArgs cra
hunk ./FrontEnd/Class.hs 107
+
+makeInstanceEnvironment :: ClassHierarchy -> [Qual Pred]
+makeInstanceEnvironment (ClassHierarchy ch) = concatMap f (Map.elems ch) where
+    f cr@ClassRecord { classSupers = supers, className = cname } = concatMap (g cr) (classInsts cr) ++ [ [IsIn cname var] :=> IsIn s var | s <- supers ] where
+        var = let [v] = classArgs cr in TVar v
+    g cr Inst { instHead = ih@(_ :=> (IsIn _cname what)), instAssocs = as } | _cname == className cr = ans where
+        ans = ih:[ [] :=> IsEq (foldl TAp (TAp (TCon tc) what) (map TVar rs)) e | (tc,rs,e) <- as]
+
+
hunk ./FrontEnd/Class.hs 171
-    printClassDetails (cname, (ClassRecord { classSupers = supers, classInsts = insts, classAssumps = methodAssumps, classAssocs = classAssocs})) = do
+    printClassDetails (cname, (ClassRecord { classArgs = classArgs, classSupers = supers, classInsts = insts, classAssumps = methodAssumps, classAssocs = classAssocs})) = do
hunk ./FrontEnd/Class.hs 173
-        putStrLn $ "class: " ++ show cname
+        putStrLn $ "class: " ++ hsep (pprint cname:map pprint classArgs)
hunk ./FrontEnd/Class.hs 185
-    passoc (nk,as,mt) = text "type" <+> pb nk <+> hsep (map pb as) <> case mt of
+    passoc (nk,as,mt) = text "type" <+> pprint nk <+> hsep (map pprint as) <> case mt of
hunk ./FrontEnd/Class.hs 188
-    pb (n,Star) = pprint n
-    pb (n,k) = parens (pprint n <+> text "::" <+> pprint k)
+--    pb (n,Star) = pprint n
+--    pb (n,k) = parens (pprint n <+> text "::" <+> pprint k)
hunk ./FrontEnd/Class.hs 211
-hsInstDeclToInst kt (HsInstDecl _sloc qType _decls)
+hsInstDeclToInst kt (HsInstDecl _sloc qType decls)
hunk ./FrontEnd/Class.hs 213
-        = return [(False,emptyInstance { instHead = cntxt :=> IsIn className convertedArgType })]
-   | otherwise
-        = failSl _sloc $ "hsInstDeclToInst: kind error, attempt to make\n" ++
-                  show argType ++ " (with kind " ++
-                  show argTypeKind ++ ")\n" ++
-                  "an instance of class " ++ show className ++
-                  " (with kind " ++ show classKind ++ ")"
+        = return [(False,emptyInstance { instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs })]
+   | otherwise = failSl _sloc $ "hsInstDeclToInst: kind error, attempt to make\n" ++
+                      show convertedArgType ++ " (with kind " ++ show argTypeKind ++ ")\n" ++
+                      "an instance of class " ++ show className ++
+                      " (with kind " ++ show classKind ++ ")"
hunk ./FrontEnd/Class.hs 219
-   (cntxt, classType, argType)
-      = case toHsQualType qType of
-           HsQualType context (HsTyApp cType@(HsTyCon _) aType)
-              -> (map (hsAsstToPred kt) context, cType, aType)
+   (cntxt, (className, cargs@[convertedArgType])) = qtToClassHead kt qType
+   classKind = kindOfClass className kt
+   argTypeKind = map getType cargs
+   assocs = [ (tc,rs,s) | (tc,~(_:rs),~(Just s)) <- createClassAssocs kt decls ]
+
+--   (cntxt, classType, argType)
+--      = case toHsQualType qType of
+--           HsQualType context (HsTyApp cType@(HsTyCon _) aType)
+--              -> (map (hsAsstToPred kt) context, cType, aType)
hunk ./FrontEnd/Class.hs 237
-   -}
hunk ./FrontEnd/Class.hs 252
-   className = nameOfTyCon ClassName classType
-   [classKind] = kindOfClass className kt
+--   className = nameOfTyCon ClassName classType
+--   [classKind] = kindOfClass className kt
+   -}
hunk ./FrontEnd/Class.hs 325
-createClassAssocs kt decls = [ (ct TypeConstructor n,map (ct TypeVal) as,ctype t)| HsTypeDecl { hsDeclName = n, hsDeclArgs = as, hsDeclType = t } <- decls ] where
-    ct nameType n = let nn = toName nameType n in (nn,kindOf nn kt)
+createClassAssocs kt decls = [ (ctc n,map ct as,ctype t)| HsTypeDecl { hsDeclName = n, hsDeclArgs = as, hsDeclType = t } <- decls ] where
+    ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt)
+    ct n = let nn = toName TypeVal n in tyvar nn (kindOf nn kt)
hunk ./FrontEnd/Class.hs 335
-    cacntxt = [ IsEq (TAp (TCon (Tycon n k)) th) (tsubst (uncurry tyvar na) cvar v) | ((n,k),[na],~(Just v)) <- createClassAssocs kt methods]
+    cacntxt = [ IsEq (TAp (TCon tcon) th) (tsubst na cvar v) | (tcon,[na],~(Just v)) <- createClassAssocs kt methods]
hunk ./FrontEnd/Class.hs 354
-
-
hunk ./FrontEnd/Class.hs 423
-
-   --newQualType = runIdentity $ (applyTP $ full_tdTP (adhocTP idTP at)) $ quantify (tv qt) qt
-   --at (Tyvar n k) = return $ Tyvar (hsNameIdent_u (hsIdentString_u (++ foo)) n) k
-   --qt = (map (aHsAsstToPred kt) newCntxt ++ restContext) :=> (runIdentity $ applyTP (full_tdTP $ adhocTP idTP ct) t)
-   --ct n | n == classArg = return $ aHsTypeToType kt instanceType
-   --ct n = return n
hunk ./FrontEnd/Class.hs 431
-{-
-newMethodSig :: HsContext -> HsName -> HsDecl -> HsType -> HsDecl
-newMethodSig newCntxt newName (HsTypeSig _sloc methodName (HsQualType cntxt t)) instanceType
-   = HsTypeSig bogusASrcLoc [newName] newQualType
-   where
-   -- the assumption is that the context is non-empty and that
-   -- the class and variable that we are interested in are at the
-   -- front of the old context - the method of inserting instance types into
-   -- the class hierarchy should ensure this
-   ((className, classArg):restContxt) = cntxt
-   newT = oneTypeReplace (HsTyVar classArg, instanceType) t
-   newQualType
-      = let finalCntxt = newCntxt++restContxt
-           in case finalCntxt of
-                 []    -> HsUnQualType newT
-                 (_:_) -> HsQualType finalCntxt newT
--- -}
hunk ./FrontEnd/Class.hs 452
-            tell [ClassRecord { classAssocs = classAssocs, className = toName ClassName className, classSrcLoc = sl, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classDerives = [], classAssumps = qualifiedMethodAssumps }]
-
+            tell [ClassRecord { classArgs = classArgs, classAssocs = classAssocs, className = toName ClassName className, classSrcLoc = sl, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classDerives = [], classAssumps = qualifiedMethodAssumps }]
hunk ./FrontEnd/Class.hs 456
-        classAssocs = [ (ct TypeConstructor n,map (ct TypeVal) as,ctype t)| HsTypeDecl { hsDeclName = n, hsDeclArgs = as, hsDeclType = t } <- decls ] where
-            ct nameType n = let nn = toName nameType n in (nn,kindOf nn kt)
-            ctype HsTyAssoc = Nothing
-            ctype t = Just $ runIdentity $ hsTypeToType kt t
+        classAssocs = createClassAssocs kt decls
+        (_,(_,classArgs')) = qtToClassHead kt t
+        classArgs = [ v | ~(TVar v) <- classArgs' ]
hunk ./FrontEnd/Tc/Class.hs 19
+import Representation(Class)
hunk ./FrontEnd/Tc/Class.hs 22
-import Representation(Class)
hunk ./FrontEnd/Tc/Class.hs 23
-import Name.Names
-import Options
hunk ./FrontEnd/Tc/Class.hs 24
-import Support.CanType
-import qualified FlagOpts as FO
-import qualified FlagDump as FD
+import Doc.PPrint
hunk ./FrontEnd/Tc/Class.hs 26
-import FrontEnd.Tc.Type
hunk ./FrontEnd/Tc/Class.hs 27
-import Doc.PPrint
+import FrontEnd.Tc.Type
+import Name.Names
+import Options
+import Support.CanType
hunk ./FrontEnd/Tc/Class.hs 32
+import qualified FlagDump as FD
+import qualified FlagOpts as FO