[add type equality constraints to abstract syntax, predicate types, and parser
John Meacham <john@repetae.net>**20061018021546] hunk ./FrontEnd/Class.hs 87
-
hunk ./FrontEnd/Class.hs 158
-   newClassContext = [(className, argName)]
+   newClassContext = [HsAsst (nameName className) [nameName argName]] -- [(className, argName)]
+   className,argName :: Name
hunk ./FrontEnd/Class.hs 162
-   in return $ ClassHierarchy $ Map.insertWith combineClassRecords  className ClassRecord { classSrcLoc = bogusASrcLoc, className = className, classSupers = map fst (hsContextToContext cntxt), classInsts = [], classDerives = [], classAssumps = qualifiedMethodAssumps } h
+   in return $ ClassHierarchy $ Map.insertWith combineClassRecords  className ClassRecord { classSrcLoc = bogusASrcLoc, className = className, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [], classDerives = [], classAssumps = qualifiedMethodAssumps } h
hunk ./FrontEnd/Class.hs 177
-qualifyMethod :: Context -> (HsDecl) -> (HsDecl)
-qualifyMethod [(c,n)] (HsTypeSig sloc names (HsQualType oc t))
-    = HsTypeSig sloc names (HsQualType ((nameName c,n'):oc) t) where
-        --n' = fromJust $ applyTU (once_tdTU $ adhocTU failTU f) t
-        --f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig n = return n'
-        --f (HsTyVar n')  = return n'
-        --f _ = mzero
+qualifyMethod :: [HsAsst] -> HsDecl -> HsDecl
+qualifyMethod [HsAsst c [n]] (HsTypeSig sloc names (HsQualType oc t))
+    = HsTypeSig sloc names (HsQualType (HsAsst c [n']:oc) t) where
hunk ./FrontEnd/Class.hs 181
-        f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig (nameName n) = return n'
+        f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig n = return n'
hunk ./FrontEnd/Class.hs 572
-                newClassContext = hsContextToContext [(className, argName)]
-            tell [ClassRecord { className = toName ClassName className, classSrcLoc = sl, classSupers = map fst $ hsContextToContext cntxt, classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classDerives = [], classAssumps = qualifiedMethodAssumps }]
+                newClassContext = [HsAsst className [argName]] -- hsContextToContext [(className, argName)]
+            tell [ClassRecord { 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/HsParser.ly 415
+>	| '(' type '=' type ')'         { HsTyEq $2 $4 }
hunk ./FrontEnd/HsParser.ly 558
+>	| 'type' simpletype srcloc
+>			{ HsTypeDecl $3 (fst $2) (snd $2) HsTyAssoc }
hunk ./FrontEnd/HsPretty.hs 34
+import Name.Names
+import Name.Name
hunk ./FrontEnd/HsPretty.hs 412
+ppHsTypePrec p (HsTyAssoc) = text "<assoc>"
+ppHsTypePrec p (HsTyEq a b) =
+	parensIf (p > 0) $ myFsep [ppHsType a, text "=", ppHsType b]
hunk ./FrontEnd/HsPretty.hs 417
-ppHsTypePrec p (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsIdent "[]"))) b ) =
-	brackets $ ppHsType b
+ppHsTypePrec p (HsTyApp (HsTyCon lcons) b ) | lcons == nameName tc_List = brackets $ ppHsType b
hunk ./FrontEnd/HsPretty.hs 422
---ppHsTypePrec p (HsTyCon (Qual (Module "Prelude") n)) = ppHsNameParen (UnQual n)
hunk ./FrontEnd/HsPretty.hs 636
-ppHsAsst (a,ts) = myFsep(ppHsQName a : [ppHsName ts])
+ppHsAsst (HsAsst a ts) = myFsep(ppHsQName a : map ppHsName ts)
+ppHsAsst (HsAsstEq a b) = ppHsType a <+> char '=' <+> ppHsType b
hunk ./FrontEnd/HsSyn.hs 228
+         -- the following are used internally
+         | HsTyAssoc
+         | HsTyEq HsType HsType
hunk ./FrontEnd/HsSyn.hs 248
-type HsAsst    = (HsName,HsName)	-- clobber
+--type HsAsst    = (HsName,HsName)	-- clobber
+
+data HsAsst = HsAsst HsName [HsName] | HsAsstEq HsType HsType
+  deriving(Data,Typeable,Eq,Ord, Show)
+    {-! derive: GhcBinary !-}
hunk ./FrontEnd/KindInfer.hs 21
+import Control.Monad.Identity
hunk ./FrontEnd/KindInfer.hs 269
-kiAsst x@(className, argName) = withContext ("kiAsst: " ++ show x) $ do
+kiAsst x@(HsAsst className [argName]) = withContext ("kiAsst: " ++ show x) $ do
hunk ./FrontEnd/KindInfer.hs 416
-namesFromContext cntxt = map fst (hsContextToContext cntxt)
+namesFromContext cntxt = concatMap f cntxt where
+    f (HsAsst x xs) = toName ClassName x:map (toName TypeVal) xs
+    f (HsAsstEq a b) = namesFromType a ++ namesFromType b
hunk ./FrontEnd/KindInfer.hs 564
-hsAsstToPred kt (className, varName)
+hsAsstToPred kt (HsAsst className [varName])
hunk ./FrontEnd/KindInfer.hs 568
+hsAsstToPred kt (HsAsstEq t1 t2) = IsEq (runIdentity $ hsTypeToType kt t1) (runIdentity $ hsTypeToType kt t2)
hunk ./FrontEnd/ParseUtils.hs 26
-	, checkPatterns	
+	, checkPatterns
hunk ./FrontEnd/ParseUtils.hs 77
-                tast (a,[HsTyVar n]) = return (a,n)
-                tast _ = fail "Invalid Class. multiparameter?"
+                tast (a,[HsTyVar n]) = return (HsAsst a [n]) -- (a,n)
+                tast _ = fail "Invalid Class. multiparameter classes not yet supported"
hunk ./FrontEnd/Rename.hs 420
-renameHsAsst :: HsAsst -> SubTable -> ScopeSM (HsAsst)
-renameHsAsst (hsName1, hsName2) subTable = do
+renameHsAsst :: HsAsst -> SubTable -> ScopeSM HsAsst
+renameHsAsst (HsAsst hsName1  hsName2s) subTable = do
hunk ./FrontEnd/Rename.hs 423
-      hsName2' <- renameTypeHsName hsName2 subTable
-      return (hsName1', hsName2')
+      hsName2s' <- mapRename renameTypeHsName hsName2s subTable
+      return (HsAsst hsName1' hsName2s')
+renameHsAsst (HsAsstEq t1 t2) subTable = do
+      t1' <- renameHsType t1 subTable  -- for class names
+      t2' <- renameHsType t2 subTable  -- for class names
+      return (HsAsstEq t1' t2')
hunk ./FrontEnd/Rename.hs 497
+    rt (HsTyAssoc) subTable = return HsTyAssoc
+    rt (HsTyEq a b) subTable = return HsTyEq `ap` (flip renameAny subTable a) `ap` (flip renameAny subTable b)
hunk ./FrontEnd/Rename.hs 1269
+instance Renameable HsAsst where
+    replaceName f (HsAsst x xs) = HsAsst (replaceName f x) (replaceName f xs)
+    replaceName f (HsAsstEq x y) = HsAsstEq (replaceName f x) (replaceName f y)
hunk ./FrontEnd/Representation.hs 198
-data Pred   = IsIn Class Type
+data Pred   = IsIn Class Type | IsEq Type Type
hunk ./FrontEnd/Syn/Traverse.hs 131
-traverseHsType f (HsTyFun a b) = do
-    a <- f a
-    b <- f b
-    return $ HsTyFun a b
+traverseHsType f (HsTyFun a b) = return HsTyFun `ap` f a `ap` f b
hunk ./FrontEnd/Syn/Traverse.hs 135
-traverseHsType f (HsTyApp a b) = do
-    a <- f a
-    b <- f b
-    return $ HsTyApp a b
-traverseHsType f (HsTyForall vs qt) = do
-    x <- f $ hsQualTypeType qt
-    return $ HsTyForall vs qt { hsQualTypeType = x }
-traverseHsType f (HsTyExists vs qt) = do
-    x <- f $ hsQualTypeType qt
-    return $ HsTyExists vs qt { hsQualTypeType = x }
+traverseHsType f (HsTyApp a b) = return HsTyApp `ap` f a `ap` f b
+traverseHsType f (HsTyForall vs qt) = doQual HsTyForall f vs qt
+traverseHsType f (HsTyExists vs qt) = doQual HsTyExists f vs qt
hunk ./FrontEnd/Syn/Traverse.hs 140
+traverseHsType _ HsTyAssoc = return HsTyAssoc
+traverseHsType f (HsTyEq a b) = return HsTyEq `ap` f a `ap` f b
+
+doQual hsTyForall f vs qt = do
+    x <- f $ hsQualTypeType qt
+    cntx <- flip mapM (hsQualTypeContext qt) $ \v -> case v of
+        x@HsAsst {} -> return x
+        HsAsstEq a b -> return HsAsstEq `ap` f a `ap` f b
+    return $ hsTyForall vs qt { hsQualTypeContext = cntx, hsQualTypeType = x }
hunk ./FrontEnd/TypeSynonyms.hs 40
-declsToTypeSynonyms ts = TypeSynonyms $ Map.fromList [ (toName TypeConstructor name,( args , quantifyHsType args (HsQualType [] t) , sl)) | (HsTypeDecl sl name args t) <- ts]
+declsToTypeSynonyms ts = TypeSynonyms $ Map.fromList $
+    [ (toName TypeConstructor name,( args , quantifyHsType args (HsQualType [] t) , sl)) | (HsTypeDecl sl name args t) <- ts]
+    ++  [ (toName TypeConstructor name,( args , HsTyAssoc, sl)) | (HsClassDecl _ _ ds) <- ts,(HsTypeDecl sl name args _) <- ds]
hunk ./FrontEnd/TypeSynonyms.hs 66
-          else do
-            st <- subst (Map.fromList [(a,s) | a <- args | s <- stack]) t
-            eval (drop (length args) stack) st
+          else case t of
+            HsTyAssoc -> unwind x stack
+            _ -> do
+                st <- subst (Map.fromList [(a,s) | a <- args | s <- stack]) t
+                eval (drop (length args) stack) st
hunk ./FrontEnd/TypeSynonyms.hs 95
-        let ps' = [ case Map.lookup n sm of Just (HsTyVar n') -> (c,n') ; _ -> (c,n) | (c,n) <- ps ]
+        let f (HsAsst c xs) = return (HsAsst c (map g xs))
+            f (HsAsstEq a b) = do
+                a' <- subst sm a
+                b' <- subst sm b
+                return (HsAsstEq a' b')
+            g n =  case Map.lookup n sm of Just (HsTyVar n') -> n' ; _ -> n
+        ps' <- mapM f ps -- = [ case Map.lookup n sm of Just (HsTyVar n') -> (c,n') ; _ -> (c,n) | (c,n) <- ps ]
+
hunk ./FrontEnd/TypeSyns.hs 177
-renameHsAsst (hsName1, hsName2) subTable = do
+renameHsAsst (HsAsst hsName1  hsName2s) subTable = do
hunk ./FrontEnd/TypeSyns.hs 179
-      hsName2' <- renameTypeHsName hsName2 subTable
-      return (hsName1', hsName2')
+      hsName2s' <- mapRename renameTypeHsName hsName2s subTable
+      return (HsAsst hsName1' hsName2s')
+renameHsAsst (HsAsstEq t1 t2) subTable = do
+      t1' <- renameHsType t1 subTable  -- for class names
+      t2' <- renameHsType t2 subTable  -- for class names
+      return (HsAsstEq t1' t2')
hunk ./FrontEnd/TypeSyns.hs 238
+    rt (HsTyAssoc) subTable = return HsTyAssoc
+    rt (HsTyEq a b) subTable = return HsTyEq `ap` (flip rt subTable a) `ap` (flip rt subTable b)
hunk ./FrontEnd/TypeSyns.hs 884
+instance Renameable HsAsst where
+    replaceName f (HsAsst x xs) = HsAsst (replaceName f x) (replaceName f xs)
+    replaceName f (HsAsstEq x y) = HsAsstEq (replaceName f x) (replaceName f y)
+
hunk ./FrontEnd/Utils.hs 61
-type Context = [(Name,Name)]
-hsContextToContext :: HsContext -> [(Name,Name)]
-hsContextToContext xs = [ (toName ClassName c, toName TypeVal t) | (c,t) <- xs]