Commit 3ff76be4 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

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

parent c50feaff
......@@ -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')
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment