The type constructor environment now stores information for all constructors of a data type

src/Checks/InterfaceCheck.hs

@@ -108,17 +108,14 @@ checkImport (HidingDataDecl p tc tvs)
         check (RenamingType tc' n' _)
           | tc == tc' && length tvs == n' = Just ok
         check _                           = Nothing
-checkImport (IDataDecl p tc tvs cs hs) = checkTypeInfo "data type" check p tc
+checkImport (IDataDecl p tc tvs cs _) = checkTypeInfo "data type" check p tc
   where check (DataType     tc' n' cs')
           | tc == tc' && length tvs == n' &&
-            (null cs || length cs == length cs') &&
-            and (zipWith isVisible cs (fmap (fmap constrIdent) cs'))
+            (null cs || map constrId cs == map constrIdent cs')
           = Just (mapM_ (checkConstrImport tc tvs) cs)
         check (RenamingType tc' n'   _)
           | tc == tc' && length tvs == n' && null cs = Just ok
         check _ = Nothing
-        isVisible c (Just c') = constrId c == c'
-        isVisible c Nothing   = (constrId c) `elem` hs
 checkImport (INewtypeDecl p tc tvs nc _)
   = checkTypeInfo "newtype" check p tc
   where check (RenamingType tc' n' nc')

src/Checks/TypeCheck.hs

@@ -254,7 +254,7 @@ bindTypes ds = do
 
 bindTC :: ModuleIdent -> TCEnv -> Decl -> TCEnv -> TCEnv
 bindTC m tcEnv (DataDecl _ tc tvs cs) =
-  bindTypeInfo DataType m tc tvs (map (Just . mkData) cs)
+  bindTypeInfo DataType m tc tvs (map mkData cs)
   where
   mkData (ConstrDecl _ evs     c  tys) = mkData' evs c  tys
   mkData (ConOpDecl  _ evs ty1 op ty2) = mkData' evs op [ty1, ty2]
@@ -330,11 +330,6 @@ bindLabels = do
   tcEnv <- getTyConsEnv
   modifyValueEnv $ bindLabels' m tcEnv
 
--- bindLabels :: TCM ()
--- bindLabels = do
---   tcEnv <- getTyConsEnv
---   modifyValueEnv $ bindLabels' tcEnv
-
 bindLabels' :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
 bindLabels' m tcEnv tyEnv = foldr (bindData . snd) tyEnv
                           $ localBindings tcEnv
@@ -359,18 +354,6 @@ bindLabels' m tcEnv tyEnv = foldr (bindData . snd) tyEnv
                    (ForAll n (TypeArrow lty ty))
   constrType' tc n = TypeConstructor tc $ map TypeVariable [0 .. n - 1]
 
--- bindLabels' :: TCEnv -> ValueEnv -> ValueEnv
--- bindLabels' tcEnv tyEnv = foldr (bindFieldLabels . snd) tyEnv
---                         $ localBindings tcEnv
---   where
---   bindFieldLabels (AliasType r _ (TypeRecord fs)) env =
---     foldr (bindField r) env fs
---   bindFieldLabels _ env = env
--- 
---   bindField r (l, ty) env = case lookupValue l env of
---     [] -> bindLabel l r (polyType ty) env
---     _  -> env
-
 -- Type Signatures:
 -- The type checker collects type signatures in a flat environment. All
 -- anonymous variables occurring in a signature are replaced by fresh
@@ -1071,11 +1054,11 @@ gen gvs ty = ForAll (length tvs)
 
 constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme
 constrType m c tyEnv = case qualLookupValue c tyEnv of
-  [DataConstructor  _ _ sigma] -> sigma
-  [NewtypeConstructor _ sigma] -> sigma
+  [DataConstructor  _ _ _ sigma] -> sigma
+  [NewtypeConstructor _ _ sigma] -> sigma
   _ -> case qualLookupValue (qualQualify m c) tyEnv of
-    [DataConstructor  _ _ sigma] -> sigma
-    [NewtypeConstructor _ sigma] -> sigma
+    [DataConstructor  _ _ _ sigma] -> sigma
+    [NewtypeConstructor _ _ sigma] -> sigma
     _ -> internalError $ "TypeCheck.constrType " ++ show c
 
 varArity :: Ident -> ValueEnv -> Int
@@ -1106,7 +1089,8 @@ labelType m l tyEnv = case qualLookupValue l tyEnv of
   [Label _ _ sigma] -> sigma
   _ -> case qualLookupValue (qualQualify m l) tyEnv of
     [Label _ _ sigma] -> sigma
-    _ -> internalError $ "TypeCheck.labelType " ++ show l ++ ", more precisely " ++ show (unqualify l)
+    _ -> internalError $ "TypeCheck.labelType " ++ show l
+          ++ ", more precisely " ++ show (unqualify l)
 
 -- The function 'expandType' expands all type synonyms in a type
 -- and also qualifies all type constructors with the name of the module

src/Checks/WarnCheck.hs

@@ -706,10 +706,10 @@ getTyCons _ (TypeConstructor tc _) = do
   tc'   <- unAlias tc
   tcEnv <- gets tyConsEnv
   return $ case lookupTC (unqualify tc) tcEnv of
-    [DataType     _ _ cs] -> catMaybes cs
+    [DataType     _ _ cs] -> cs
     [RenamingType _ _ nc] -> [nc]
     _ -> case qualLookupTC tc' tcEnv of
-      [DataType     _ _ cs] -> catMaybes cs
+      [DataType     _ _ cs] -> cs
       [RenamingType _ _ nc] -> [nc]
       err                   -> internalError $ "Checks.WarnCheck.getTyCons: "
                             ++ show tc ++ ' ' : show err ++ '\n' : show tcEnv

src/Env/TypeConstructor.hs

@@ -53,7 +53,7 @@ import Base.Types
 import Base.Utils ((++!))
 
 data TypeInfo
-  = DataType     QualIdent Int [Maybe DataConstr]
+  = DataType     QualIdent Int [DataConstr]
   | RenamingType QualIdent Int DataConstr
   | AliasType    QualIdent Int Type
     deriving Show
@@ -64,10 +64,8 @@ instance Entity TypeInfo where
   origName (AliasType    tc _ _) = tc
 
   merge (DataType tc n cs) (DataType tc' _ cs')
-    | tc == tc' = Just $ DataType tc n $ mergeData cs cs'
-    where mergeData ds       []         = ds
-          mergeData []       ds         = ds
-          mergeData (d : ds) (d' : ds') = d `mplus` d' : mergeData ds ds'
+    | tc == tc' && (null cs || null cs' || cs == cs') =
+        Just $ DataType tc n (if null cs then cs' else cs)
   merge (DataType tc n _) (RenamingType tc' _ nc)
     | tc == tc' = Just (RenamingType tc n nc)
   merge l@(RenamingType tc _ _) (DataType tc' _ _)
@@ -76,10 +74,6 @@ instance Entity TypeInfo where
     | tc == tc' = Just l
   merge l@(AliasType tc _ _) (AliasType tc' _ _)
     | tc == tc' = Just l
-  merge l@(AliasType tc _ (TypeRecord _)) (DataType tc' _ _)
-    | tc == tc' = Just l
-  merge (DataType tc' _ _) r@(AliasType tc _ (TypeRecord _))
-    | tc == tc' = Just r
   merge _ _ = Nothing
 
 tcArity :: TypeInfo -> Int
@@ -126,12 +120,12 @@ initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes
 type TypeEnv = TopEnv TypeKind
 
 data TypeKind
-  =  Data QualIdent [Ident]
+  = Data QualIdent [Ident]
   | Alias QualIdent
   deriving (Eq, Show)
 
 typeKind :: TypeInfo -> TypeKind
-typeKind (DataType     tc _ cs) = Data tc [ c | Just (DataConstr c _ _) <- cs ]
+typeKind (DataType     tc _ cs) = Data tc (map constrIdent cs)
 typeKind (RenamingType tc _ (DataConstr c _ _)) = Data tc [c]
 typeKind (AliasType    tc _ _) = Alias tc
 

src/Imports.hs

@@ -178,24 +178,18 @@ bindTCHidden m d                         = bindTC m d
 
 -- type constructors
 bindTC :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv
-bindTC m (IDataDecl _ tc tvs cs hs) mTCEnv
+bindTC m (IDataDecl _ tc tvs cs _) mTCEnv
   | unqualify tc `Map.member` mTCEnv = mTCEnv
   | otherwise = bindType DataType m tc tvs (map mkData cs) mTCEnv
   where
-   mkData (ConstrDecl _ evs c tys)
-     | c `elem` hs = Nothing
-     | otherwise   = Just $ DataConstr c (length evs) (toQualTypes m tvs tys)
-   mkData (ConOpDecl _ evs ty1 c ty2)
-     | c `elem` hs = Nothing
-     | otherwise   = Just $
-         DataConstr c (length evs) (toQualTypes m tvs [ty1,ty2])
-   mkData (RecordDecl _ evs c fs)
-     | c `elem` hs = Nothing
-     | otherwise   = Just $ RecordConstr c (length evs) labels' tys'
+   mkData (ConstrDecl _ evs c tys) =
+     DataConstr c (length evs) (toQualTypes m tvs tys)
+   mkData (ConOpDecl _ evs ty1 c ty2) =
+     DataConstr c (length evs) (toQualTypes m tvs [ty1,ty2])
+   mkData (RecordDecl _ evs c fs) =
+     RecordConstr c (length evs) labels (toQualTypes m tvs tys)
      where
        (labels, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]
-       labels'       = filter (`notElem` hs) labels
-       tys'          = toQualTypes m tvs tys
 
 bindTC m (INewtypeDecl _ tc tvs newCons _) mTCEnv =
   bindType RenamingType m tc tvs (mkData newCons) mTCEnv