[added abstract associated type synonyms
mail@stefanwehr.de**20050929010821] {
adddir ./tests/abstract-assoc-types
adddir ./tests/abstract-assoc-types/should_fail
adddir ./tests/abstract-assoc-types/should_pass
hunk ./Phrac/Lexer.x 106
-    of|qualified|then|type|where|forall
+    of|qualified|then|type|where|forall|abstype
hunk ./Phrac/ParseSyntax.hs 122
+data AssocTypeStatus = AssocTypeNotAbstract | AssocTypeAbstract
+                       deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)
+
hunk ./Phrac/ParseSyntax.hs 128
-                                     assocBind_def :: Type
+                                     assocBind_def :: Type,
+                                     assocBind_status :: AssocTypeStatus
hunk ./Phrac/ParseSyntax.hs 133
+class Abstract a where
+    isAbstract :: a -> Bool
+    isConcrete :: a -> Bool
+    isConcrete x = not $ isAbstract x
+
+instance Abstract AssocTypeStatus where
+    isAbstract AssocTypeNotAbstract = False
+    isAbstract AssocTypeAbstract = True
+
+instance Abstract AssocTypeBind where
+    isAbstract atb = isAbstract (assocBind_status atb)
hunk ./Phrac/ParseSyntax.hs 552
-    ppr (AssocTypeBind name indices params def) =
+    ppr (AssocTypeBind name indices params def status) =
+        (if isAbstract status then text "abstype" else text "type") <+>
hunk ./Phrac/ParseSyntax.hs 564
-    ppr (AssocTypeSig id tyvars Nothing) = ppr id <+> hsep (map ppr tyvars)
+    ppr (AssocTypeSig id tyvars Nothing) = 
+        text "type" <+> ppr id <+> hsep (map ppr tyvars)
hunk ./Phrac/ParseSyntax.hs 567
-        ppr id <+> hsep (map ppr tyvars) <+> text "+" <+> ppr def
+        text "type" <+> ppr id <+> hsep (map ppr tyvars) <+> text "+" <+> ppr def
hunk ./Phrac/Parser.y 76
+    'abstype'      { T _ (ReservedIdT "abstype") }
hunk ./Phrac/Parser.y 160
-      { (AssocTypeBind $2 $3 [] $5) }
+      { (AssocTypeBind $2 $3 [] $5 AssocTypeNotAbstract) }
+  | 'abstype' tycon atypes '=' type  
+      { (AssocTypeBind $2 $3 [] $5 AssocTypeAbstract) }
hunk ./Phrac/Symtab.hs 34
-  findTypeDef, getGlobalEqualities, findSuperClasses, findAllSuperClasses,
+  findTypeDef, findSuperClasses, findAllSuperClasses,
hunk ./Phrac/Symtab.hs 37
+
+  getGlobalEqualities, addConcreteEqualities, deleteConcreteEqualities,
hunk ./Phrac/Symtab.hs 61
+
+-- Note: we don't have equality definitions for abstract associated
+-- type synonyms. This means we cannot define instances for such abstract
+-- associated type synonyms.
hunk ./Phrac/Symtab.hs 67
-    { classMap          :: Map.Map ClassId (ClassDec, [ClassInst]),
-      assocTypeSigMap   :: Map.Map AssocTypeId AssocTypeSig,
-      typeVarKindMap    :: Map.Map TypeVarId Kind,
-      typeDefMap        :: Map.Map TypeId TypeDef,
-      nameSupply        :: (UniqIdents.Version, -- next free version
-                            String,             -- prefix for type variables
-                            String,             -- prefix for type constructors
-                            String),            -- prefix for value variables
-      globalEqualities  :: [EqualityDefinition],  -- assoc type definitions
-      methods           :: Set.Set ValId,  -- which value ids are methods? 
-      dictExprs         :: Map.Map (ClassId, [Type]) Exp,
-      configuration     :: Configuration
+    { classMap            :: Map.Map ClassId (ClassDec, [ClassInst]),
+      assocTypeSigMap     :: Map.Map AssocTypeId AssocTypeSig,
+      typeVarKindMap      :: Map.Map TypeVarId Kind,
+      typeDefMap          :: Map.Map TypeId TypeDef,
+      nameSupply          :: (UniqIdents.Version, -- next free version
+                              String,             -- prefix for type variables
+                              String,             -- prefix for type constructors
+                              String),            -- prefix for value variables
+      globalEqualities    :: [EqualityDefinition],-- assoc type definitions
+      concreteEqualities  :: [EqualityDefinition],-- abstract assoc type definitions
+                                                  -- made concrete, e.g. for checking
+                                                  -- the body of an instance
+      methods             :: Set.Set ValId,  -- which value ids are methods? 
+      dictExprs           :: Map.Map (ClassId, [Type]) Exp,
+      configuration       :: Configuration
hunk ./Phrac/Symtab.hs 91
+                       concreteEqualities = [],
hunk ./Phrac/Symtab.hs 230
-getGlobalEqualities = gets globalEqualities
+getGlobalEqualities = 
+    do glob <- gets globalEqualities
+       concr <- gets concreteEqualities
+       return $ concr ++ glob
+
+-- Add the concrete right-hand sides of the abstract type synonyms of the 
+-- given instance to the global equality definitions
+addConcreteEqualities :: ClassInst -> ST ()
+addConcreteEqualities ci =
+    let -- add the assoc type definitions
+        quants = freeTypeVarsList (inst_types ci)
+        eqs = map mkEqConstraint (filter isAbstract $ inst_typeBinds ci)
+        eqdefs = map (EqualityDefinition quants) eqs
+    in do old <- gets concreteEqualities
+          if not $ null old
+             then panic ("INTERNAL ERROR: " ++
+                         "cannot add concrete equalities for abstract associated "++
+                         "type synonyms. Reaons: there are already some concrete "++
+                         "equalities. This violates an invariant")
+             else do modify (\s -> s { concreteEqualities = eqdefs })
+                     debug ("added concrete equalities: " ++ showPpr eqdefs)
+
+
+-- Delete all concrete equality definitions resulting from abstract
+-- associated type synonyms
+deleteConcreteEqualities :: ST ()
+deleteConcreteEqualities = 
+    do modify (\s -> s { concreteEqualities = [] })
hunk ./Phrac/Symtab.hs 306
--- This is a bit a hack, I know, but otherwise tests would break if we
--- add anything to the prelude :-)
+-- This is a bit of a hack, I know, but otherwise tests break if we
+-- add something to the prelude :-)
hunk ./Phrac/Symtab.hs 392
+                      -- equalities for fixed associated type synonyms
hunk ./Phrac/Symtab.hs 410
-        eqs = map mkEqConstraint (inst_typeBinds ci)
+        eqs = map mkEqConstraint (filter isConcrete $ inst_typeBinds ci)
hunk ./Phrac/Symtab.hs 420
-          mkEqConstraint assoc =
-              let left = AssocType (assocBind_name assoc) 
-                           (assocBind_indices assoc ++
-                            map TyVar (assocBind_params assoc))
-                  right = assocBind_def assoc
-                  in EqConstraint left right
+
+-- makes an equality constraint using the concrete rhs
+mkEqConstraint :: AssocTypeBind -> EqConstraint
+mkEqConstraint assoc =
+    let left = AssocType (assocBind_name assoc) 
+                 (assocBind_indices assoc ++
+                  map TyVar (assocBind_params assoc))
+        right = assocBind_def assoc
+        in EqConstraint left right
+
hunk ./Phrac/SyntaxTransformation.hs 204
-rw_assocTypeBind (AssocTypeBind id indices _ ty) =
+rw_assocTypeBind (AssocTypeBind id indices _ ty status) =
hunk ./Phrac/SyntaxTransformation.hs 217
-     return (AS.AssocTypeBind uid indices' params' ty')
+     return (AS.AssocTypeBind uid indices' params' ty' (rw_status status))
+  where rw_status AssocTypeNotAbstract = AS.AssocTypeNotAbstract
+        rw_status AssocTypeAbstract = AS.AssocTypeAbstract
hunk ./Phrac/TypeInference.hs 456
+                 liftST $ addConcreteEqualities ci
hunk ./Phrac/TypeInference.hs 458
+                 liftST $ deleteConcreteEqualities
+                 display ("finished checking methods of instance `" ++ 
+                          showInstHead ci ++  "'")
hunk ./Phrac/WellFormedness.hs 200
-                              (AssocTypeBind aid (map TyVar indices) params t')
+                              (AssocTypeBind aid (map TyVar indices) params t'
+                               AssocTypeNotAbstract)
hunk ./Phrac/WellFormedness.hs 356
-checkAssocTypeDefinition atb@(AssocTypeBind id p ps ty) = 
+checkAssocTypeDefinition atb@(AssocTypeBind id p ps ty _) = 
hunk ./Phrac/WellFormedness.hs 379
-checkDecreasingAssocTypeDefinition (AssocTypeBind id indices params ty) = 
+checkDecreasingAssocTypeDefinition (AssocTypeBind id indices params ty _) = 
addfile ./tests/abstract-assoc-types/should_fail/001.err
hunk ./tests/abstract-assoc-types/should_fail/001.err 1
+deferred constraints left after type inference:
+{Constraints: {T D = Int}}
addfile ./tests/abstract-assoc-types/should_fail/001.phc
hunk ./tests/abstract-assoc-types/should_fail/001.phc 1
+class C a where {
+  type T a;
+  bar :: a -> T a;
+  foo :: a -> T a -> T a;
+}
+
+data D = D;
+
+instance C D where {
+  abstype T D = Int;
+  bar _ = 41;
+  foo _ i = i+1;
+}
+
+main = foo D 0;
addfile ./tests/abstract-assoc-types/should_fail/Flag
hunk ./tests/abstract-assoc-types/should_fail/Flag 1
+expect-fail --no-location
addfile ./tests/abstract-assoc-types/should_pass/001.out
hunk ./tests/abstract-assoc-types/should_pass/001.out 1
+42
addfile ./tests/abstract-assoc-types/should_pass/001.phc
hunk ./tests/abstract-assoc-types/should_pass/001.phc 1
+class C a where {
+  type T a;
+  bar :: a -> T a;
+  foo :: a -> T a -> T a;
+}
+
+data D = D;
+
+instance C D where {
+  abstype T D = Int;
+  bar _ = 41;
+  foo _ i = i+1;
+}
+
+main = foo D (bar D);
hunk ./tests/ast/should_pass/004.out 2
-    Sum n m
+    type Sum n m
hunk ./tests/ast/should_pass/006.out 4
-    T a
+    type T a
hunk ./tests/ast/should_pass/006.out 7
-    T Int = Int -> Bool
+    type T Int = Int -> Bool
hunk ./tests/ast/should_pass/006.out 10
-    T D = Bool
+    type T D = Bool
}