[implemented fixed associated type synonyms
mail@stefanwehr.de**20050526082537] {
adddir ./tests/fixed-assoc-types
adddir ./tests/fixed-assoc-types/should_fail
adddir ./tests/fixed-assoc-types/should_fail/allow-diverge
adddir ./tests/fixed-assoc-types/should_pass
adddir ./tests/fixed-assoc-types/should_pass/allow-diverge
hunk ./KindInference.hs 369
-kiTSig :: TSig -> KI ()
-kiTSig (_, []) = panic "invalid associated type synonym declaration"
-kiTSig (id, index:rest) = 
+kiTSig :: AssocTypeSig -> KI ()
+kiTSig (AssocTypeSig id [] _) = 
+    panic ("invalid associated type synonym declaration " ++ showPpr' id)
+kiTSig (AssocTypeSig id (index:rest) def) = 
hunk ./KindInference.hs 375
-       let restKinds = take (length rest) (repeat Star)
hunk ./KindInference.hs 376
+       restKinds <-
+           case def of
+             Nothing -> return $ take (length rest) (repeat Star)
+             Just t -> do argKinds <- newKindVars (length rest)
+                          modifyEnv (insertTypeVars (zip rest argKinds))
+                          k <- kiType t
+                          unify resultKind k
+                          return argKinds
hunk ./KindInference.hs 479
-           assocs = vcat $ map printKind (zip (map fst tsigs) assocKinds)
+           assocs = vcat $ map printKind (zip (map assocSig_name tsigs) 
+                                          assocKinds)
hunk ./Kinds.hs 49
-instance HasKind TSig where
-    kindOf (id,params) =
+instance HasKind AssocTypeSig where
+    kindOf (AssocTypeSig id params _) =
hunk ./ParseSyntax.hs 86
-                            class_tsigs :: [TSig],
+                            class_tsigs :: [AssocTypeSig],
hunk ./ParseSyntax.hs 91
-type TSig = (AssocTypeId, [TypeVarId])
+data AssocTypeSig = AssocTypeSig { assocSig_name :: AssocTypeId,
+                                   assocSig_params :: [TypeVarId],
+                                   assocSig_fixed :: Maybe Type }
+                 deriving (Read, Show, Eq, Gen.Data, Gen.Typeable)
+
hunk ./ParseSyntax.hs 477
-instance Pretty TSig where
-    ppr (id, tyvars) = ppr id <+> hsep (map ppr tyvars)
+instance Pretty AssocTypeSig where
+    ppr (AssocTypeSig id tyvars Nothing) = ppr id <+> hsep (map ppr tyvars)
+    ppr (AssocTypeSig id tyvars (Just def)) = 
+        ppr id <+> hsep (map ppr tyvars) <+> text "+" <+> ppr def
hunk ./Parser.y 119
-tsigs:: { [TSig] }
+tsigs:: { [AssocTypeSig] }
hunk ./Parser.y 123
-tsig:: { TSig }
-    : 'type' tycon tyvars  { ($2, (reverse $3)) }
+tsig:: { AssocTypeSig }
+    : 'type' tycon tyvars          { (AssocTypeSig $2 (reverse $3) Nothing) }
+    | 'type' tycon tyvars '=' type { (AssocTypeSig $2 (reverse $3) (Just $5)) }
hunk ./ParserHelper.hs 54
-mkClassDec :: ([Constraint], Type) -> [TSig] -> [VSig] -> ClassDec
+mkClassDec :: ([Constraint], Type) -> [AssocTypeSig] -> [VSig] -> ClassDec
hunk ./Symtab.hs 40
+import Maybe ( mapMaybe )
hunk ./Symtab.hs 53
-      assocTypeSigMap   :: Map.Map AssocTypeId TSig,
+      assocTypeSigMap   :: Map.Map AssocTypeId AssocTypeSig,
hunk ./Symtab.hs 104
-findAssocTypeSig :: AssocTypeId -> ST TSig
+findAssocTypeSig :: AssocTypeId -> ST AssocTypeSig
hunk ./Symtab.hs 126
-              id `elem` map fst (class_tsigs cd)
+              id `elem` map assocSig_name (class_tsigs cd)
hunk ./Symtab.hs 203
-{- 
-
-FIXME: we cannot do any checks in this early stage!!!
-
-buildSymtab builds the symbol table according to the "Typing rules for 
-declarations" (Figure 3, ICFP draft). The difficulty here is the
-recursive definition of the instance environment.
-
-(1) Insert class declarations and signature of associated type
-    synonyms (rule cls). We do not check the premise of the rule
-    and we do not enter the method signature into the symbol table.
-    Class declarations are sorted topologically prior to insertion.
-    
-(2) Insert instance declarations, order does not matter (rule inst).
-    We do not check any premises of this rule.
-
-(3) Check the first premise of (rule inst), i.e. the well-formedness
-    of associated type synonyms definitions. Enter the definition
-    of the associated type synonym into the symbol table.
-
-(4) Check the premise of (rule cls), i.e. the well-formedness of method
-    signatures. Enter the signature into the symbol table.
-
-That's all we can do here. (rule val) and the unchecked premises of 
-(rule inst) are checked later. It should be noted that all "output" of
-the rules is recorded in the symbol table.
-
--}
hunk ./Symtab.hs 209
-           -- step (1)
hunk ./Symtab.hs 211
-           -- step (2)
hunk ./Symtab.hs 212
-           -- step (3)
-
-           -- step (4)
hunk ./Symtab.hs 233
+    let eqs = mapMaybe toEq (class_tsigs cd) in
hunk ./Symtab.hs 236
-                      assocTypeSigMap = foldr insertTuple (assocTypeSigMap s)
-                                          (class_tsigs cd) })
-
-
+                      assocTypeSigMap = foldr insertAssocSig (assocTypeSigMap s)
+                                          (class_tsigs cd),
+                      globalEqualities = eqs ++ (globalEqualities s) })
+    where insertAssocSig sig m = 
+              Map.insert (assocSig_name sig) sig m
+          toEq (AssocTypeSig _ _ Nothing) = Nothing
+          toEq (AssocTypeSig id (x:xs) (Just right)) = 
+            let left = AssocType id (map TyVar (x:xs))
+                in Just $ EqualityDefinition [x] (EqConstraint left right)
hunk ./SyntaxTransformation.hs 74
-          mapM (\ (id, _) -> defineAssocTypeCon id) tsigs
+          mapM (\ sig -> defineAssocTypeCon $ assocSig_name sig) tsigs
hunk ./SyntaxTransformation.hs 108
-rw_tsig :: TSig -> NA AS.TSig
-rw_tsig (id, []) = phasefail "invalid declaration of associated type synonym: \
-                             \no arguments specified"
-rw_tsig (id, t:ts) = 
+rw_tsig :: AssocTypeSig -> NA AS.AssocTypeSig
+rw_tsig (AssocTypeSig id [] _) = 
+         phasefail "invalid declaration of associated type synonym: \
+                   \no arguments specified"
+
+rw_tsig (AssocTypeSig id (t:ts) def) = 
hunk ./SyntaxTransformation.hs 117
+       def' <- case def of
+                 Nothing -> return Nothing
+                 Just x -> do x' <- rw_type x
+                              return (Just x')
hunk ./SyntaxTransformation.hs 122
-       return (uid, t':ts')
+       return (AS.AssocTypeSig uid (t':ts') def')
hunk ./WellFormedness.hs 27
+import Maybe ( isJust )
hunk ./WellFormedness.hs 148
+       checkTypeSigs d
hunk ./WellFormedness.hs 174
+-- checks the well-formedness of fixed associated type synonyms
+checkTypeSigs (ClassDec id param constrs tsigs _) = 
+    mapM_ checkTypeSig tsigs
+    where
+    checkTypeSig (AssocTypeSig _ _ Nothing) = return ()
+    checkTypeSig (AssocTypeSig aid ps (Just t)) =
+        do debug ("checking fixed associated type synonym " ++ showPpr' aid)
+           checkType (map CC constrs) t
+           case ps of
+             [] -> panic ("illegal associated type synonym definition in class."
+                          ++ " parameter list empty")
+             (x:xs) -> 
+               checkDecreasingAssocTypeDefinition 
+                 (AssocTypeBind aid (TyVar x) xs t)
+
hunk ./WellFormedness.hs 274
--- All associated type synonyms of the corresponding class must be defined
--- (we don't have default definitions).
+-- All non-fixed associated type synonyms of the corresponding class must 
+-- be defined, the fixed type synonyms must not be defined.
hunk ./WellFormedness.hs 279
-       if length (class_tsigs clazz) /= (length tyBinds)
+       let sigs = filter (\sig -> not $ isJust (assocSig_fixed sig)) 
+                    (class_tsigs clazz)
+       if length sigs /= (length tyBinds)
hunk ./WellFormedness.hs 285
-       let sigNames = List.sort $ map fst (class_tsigs clazz)
+       let sigNames = List.sort $ map assocSig_name sigs
hunk ./WellFormedness.hs 322
-       (_, params) <- findAssocTypeSig id
+       AssocTypeSig _ params _ <- findAssocTypeSig id
hunk ./WellFormedness.hs 355
-           n = if length (allAssocTypes ty) == 0 then 0 
+           n = if length (allAssocTypes ty) == 0 then -1
hunk ./WellFormedness.hs 390
-       if length (snd sig) /= length (assoc_params at)
+       if length (assocSig_params sig) /= length (assoc_params at)
addfile ./tests/fixed-assoc-types/should_fail/000.err
hunk ./tests/fixed-assoc-types/should_fail/000.err 1
+Definition of associated type synonym T2 is not decreasing. Number of data constructors in definition head: 0. Number of data constructors on the right side: 0
addfile ./tests/fixed-assoc-types/should_fail/000.phc
hunk ./tests/fixed-assoc-types/should_fail/000.phc 1
+class C1 a where {
+  type T1 a;
+}
+
+class C1 a => C2 a where {
+  type T2 a = T1 a;
+}
addfile ./tests/fixed-assoc-types/should_fail/001.err
hunk ./tests/fixed-assoc-types/should_fail/001.err 1
+illegal instance declaration for class C: type synonyms do not match
addfile ./tests/fixed-assoc-types/should_fail/001.phc
hunk ./tests/fixed-assoc-types/should_fail/001.phc 1
+class C a where {
+  type T a = a;
+}
+
+instance C Int where {
+  type T Int = Int;
+}
addfile ./tests/fixed-assoc-types/should_fail/002.err
hunk ./tests/fixed-assoc-types/should_fail/002.err 1
+attempt to unify these two kinds: Kfun Star Star, Star
addfile ./tests/fixed-assoc-types/should_fail/002.phc
hunk ./tests/fixed-assoc-types/should_fail/002.phc 1
+data D t = D t;
+
+class C a where {
+  type T a = D;
+}
+
+instance C Int where {
+}
+
+foo :: T Int;
+foo = foo;
addfile ./tests/fixed-assoc-types/should_fail/003.err
hunk ./tests/fixed-assoc-types/should_fail/003.err 1
+attempt to unify these two kinds: Star, Kfun Star Star
addfile ./tests/fixed-assoc-types/should_fail/003.phc
hunk ./tests/fixed-assoc-types/should_fail/003.phc 1
+data D a b = D (a b);
+
+class C a where {
+  type T a = D a a;
+}
addfile ./tests/fixed-assoc-types/should_fail/Flag
hunk ./tests/fixed-assoc-types/should_fail/Flag 1
+expect-fail --no-location
addfile ./tests/fixed-assoc-types/should_fail/allow-diverge/000.phc
hunk ./tests/fixed-assoc-types/should_fail/allow-diverge/000.phc 1
+class C a where {
+  type S a;
+}
+
+class D a where {
+  type T a = S a;
+}
addfile ./tests/fixed-assoc-types/should_fail/allow-diverge/Flag
hunk ./tests/fixed-assoc-types/should_fail/allow-diverge/Flag 1
+--allow-diverging-tysyns
addfile ./tests/fixed-assoc-types/should_pass/000.out
hunk ./tests/fixed-assoc-types/should_pass/000.out 1
+foo :: forall a[1] . C a[1] => a[1] -> T a[1]
addfile ./tests/fixed-assoc-types/should_pass/000.phc
hunk ./tests/fixed-assoc-types/should_pass/000.phc 1
+class C a where {
+  type T a = Int;
+}
+
+foo :: C a => a -> T a;
+foo x = 42;
addfile ./tests/fixed-assoc-types/should_pass/001.out
hunk ./tests/fixed-assoc-types/should_pass/001.out 1
+foo :: forall v[-5] . C v[-5] => v[-5] -> v[-5]
addfile ./tests/fixed-assoc-types/should_pass/001.phc
hunk ./tests/fixed-assoc-types/should_pass/001.phc 1
+data D t = D t;
+
+class C a where {
+  type T a = D a;
+  bar :: a -> T a;
+}
+
+foo x = case bar x of D y -> y;;
addfile ./tests/fixed-assoc-types/should_pass/Flag
hunk ./tests/fixed-assoc-types/should_pass/Flag 1
+--dump-infer
addfile ./tests/fixed-assoc-types/should_pass/allow-diverge/000.phc
hunk ./tests/fixed-assoc-types/should_pass/allow-diverge/000.phc 1
+class C a where {
+  type S a;
+}
+
+class C a => D a where {
+  type T a = S a;
+}
+
+instance C Bool where {
+  type S Bool = Int;
+}
+
+instance D Bool where {
+}
+
+foo :: T Bool;
+foo = 42;
+
addfile ./tests/fixed-assoc-types/should_pass/allow-diverge/Flag
hunk ./tests/fixed-assoc-types/should_pass/allow-diverge/Flag 1
+--allow-diverging-tysyns
}