summaryrefslogtreecommitdiff
path: root/lang/nhc98/patches/patch-ag
diff options
context:
space:
mode:
Diffstat (limited to 'lang/nhc98/patches/patch-ag')
-rw-r--r--lang/nhc98/patches/patch-ag144
1 files changed, 12 insertions, 132 deletions
diff --git a/lang/nhc98/patches/patch-ag b/lang/nhc98/patches/patch-ag
index c6e6c9b10a4..a6f37e5d68a 100644
--- a/lang/nhc98/patches/patch-ag
+++ b/lang/nhc98/patches/patch-ag
@@ -1,133 +1,13 @@
-$NetBSD: patch-ag,v 1.1 2004/01/16 00:59:18 kristerw Exp $
+$NetBSD: patch-ag,v 1.2 2005/05/01 22:55:07 kristerw Exp $
---- src/compiler98/TypeUnify.hs.orig 20 Feb 2003 18:23:29
-+++ src/compiler98/TypeUnify.hs 1 Apr 2003 13:54:36
-@@ -3,7 +3,7 @@
- -}
- module TypeUnify(unify,unifyr) where
-
--import NT(NT(..),NewType(..),freeNT,strNT)
-+import NT(NT(..),NewType(..),freeNT,strNT,anyVarNT)
- import IdKind
- import TypeSubst
- import TypeUtil
-@@ -20,12 +20,12 @@
-
- unify state phi (t1@(NTany tvn1),t2) =
- case applySubst phi tvn1 of
-- Nothing -> extend phi tvn1 (subst phi t2)
-+ Nothing -> extendV state phi tvn1 (subst phi t2)
- Just phitvn -> unify state phi (phitvn,subst phi t2)
-
- unify state phi (t1@(NTvar tvn1),(NTany tvn2)) =
- case applySubst phi tvn2 of
-- Nothing -> extend phi tvn2 (subst phi t1)
-+ Nothing -> extendV state phi tvn2 (subst phi t1)
- Just phitvn -> unify state phi (phitvn,subst phi t1)
-
- unify state phi (t1@(NTvar tvn1),t2) =
-@@ -35,7 +35,7 @@
-
- unify state phi (t1@(NTcons _ _),t2@(NTany tvn2)) =
- case applySubst phi tvn2 of
-- Nothing -> extend phi tvn2 (subst phi t1)
-+ Nothing -> extendV state phi tvn2 (subst phi t1)
- Just phitvn -> unify state phi (phitvn,subst phi t1)
-
- unify state phi (t1@(NTcons _ _),t2@(NTvar tvn2)) =
-@@ -81,13 +81,13 @@
- unify state phi (t1@(NTapp ta1 tb1),t2@(NTany tvn2)) =
- -- strace ("unify(2) " ++ show t1 ++ " " ++ show t2) $
- case applySubst phi tvn2 of
-- Nothing -> extend phi tvn2 (subst phi t1)
-+ Nothing -> extendV state phi tvn2 (subst phi t1)
- Just phitvn -> unify state phi (phitvn,subst phi t1)
-
- unify state phi (t1@(NTapp ta1 tb1),t2@(NTvar tvn2)) =
- -- strace ("unify(3) " ++ show t1 ++ " " ++ show t2) $
- case applySubst phi tvn2 of
-- Nothing -> extend phi tvn2 (subst phi t1)
-+ Nothing -> extendV state phi tvn2 (subst phi t1)
- Just phitvn -> unify state phi (phitvn,subst phi t1)
-
- unify state phi (t1@(NTapp ta1 tb1),t2@(NTcons c2 ts2)) =
-@@ -130,7 +130,7 @@
- unify state phi (t1@(NTexist e),t2@(NTany tvn2)) =
- -- strace ("unify exist " ++ show e ++ " any " ++ show tvn2) $
- case applySubst phi tvn2 of
-- Nothing -> extend phi tvn2 (subst phi t1)
-+ Nothing -> extendV state phi tvn2 (subst phi t1)
- Just phitvn -> unify state phi (phitvn,subst phi t1)
-
- unify state phi (t1@(NTexist e),t2@(NTvar tvn2)) =
-@@ -166,6 +166,8 @@
-
- ------
-
-+-- expand any type synonym at top, so that none is at top in result
-+expandAll :: IntState -> NT -> NT
- expandAll state t@(NTcons tcon ts) =
- case unifyExpand state tcon of
- Left _ -> t
-@@ -178,6 +180,15 @@
- Right _ -> False
- Left _ -> True
-
-+-- expand all type synonyms, so that none is left in result
-+fullyExpand :: IntState -> NT -> NT
-+fullyExpand state t =
-+ case expandAll state t of
-+ NTstrict t -> NTstrict (fullyExpand state t)
-+ NTapp t1 t2 -> NTapp (fullyExpand state t1) (fullyExpand state t2)
-+ NTcons id ts -> NTcons id (map (fullyExpand state) ts)
-+ t -> t
-+
- {-
- If tcon is a type synoym, then unifyExpand returns the depth and the
- definition body of the type synoym.
-@@ -205,27 +216,26 @@
-
- expand (NewType free [] ctxs [nt]) ts = subst (list2Subst (zip free ts)) nt
-
--
-+{-
-+Extends substitution by subtitution of `t' for `tvn'.
-+Performs occurrence check and assures that replacement of `tvn' is a type
-+variable, if `t' expands to a type variable.
-+-}
- extendV :: IntState -> AssocTree Id NT -> Id -> NT
- -> Either (AssocTree Id NT, String) (AssocTree Id NT)
-
--extendV state phi tvn t@(NTcons c _) =
-- if unboxedIS state c then
-- Left (phi,"polymorphic type variable bound to unboxed data " ++ strIS state c)
-- else
-- extend phi tvn t
- extendV state phi tvn t =
-- extend phi tvn t
-+ let t' = expandAll state t
-+ in case anyVarNT t' of
-+ Just tvn' -> if tvn' == tvn
-+ then Right phi
-+ else Right (addSubst phi tvn t')
-+ Nothing ->
-+ if tvn `elem` freeNT t'
-+ then let t'' = fullyExpand state t'
-+ -- expansion may have less free variables
-+ in if tvn `elem` freeNT t''
-+ then Left (phi,"(type-variable occurrence check fails)")
-+ else Right (addSubst phi tvn t'')
-+ else Right (addSubst phi tvn t) -- do not expand unnecessarily
-
--extend phi tvn t@(NTany tvn') =
-- if tvn' == tvn
-- then Right phi
-- else Right (addSubst phi tvn t)
--extend phi tvn t@(NTvar tvn') =
-- if tvn' == tvn
-- then Right phi
-- else Right (addSubst phi tvn t)
--extend phi tvn t | tvn `elem` freeNT t =
-- Left (phi,"(type-variable occurrence check fails)")
--extend phi tvn t@(NTcons c _) = Right (addSubst phi tvn t)
--extend phi tvn t = Right (addSubst phi tvn t)
+--- src/compiler98/RenameLib.hs 22 Dec 2004 12:58:35 -0000 1.31
++++ src/compiler98/RenameLib.hs 11 Apr 2005 14:24:49 -0000
+@@ -216,7 +216,7 @@
+ (coni:_) ->
+ case (ntI . dropJust . lookupAT st ) coni of
+ (NewType _ [] _ [NTcons c _ _,res]) -> (synType,(u,c):newType)
+- (NewType _ [] _ [NTvar v _,res]) -> (synType,(u,v):newType)
++ (NewType _ [] _ [NTvar v _,res]) -> (synType, newType)
+ (NewType _ [] _ [NTapp v1 v2,res]) -> (synType,newType)
+ -- ^ MW hack: omits potential circularity check!
+ (NewType _ [] _ (_:_:_)) ->
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-14 13:04:01 +0000