Commit 0681cc80 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Adapted checks to handle Haskell's record syntax

parent fd390fc2
......@@ -3,6 +3,7 @@
Description : Conversion of type representation
Copyright : (c) Wolfgang Lux
2011 - 2012 Björn Peemöller
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -67,10 +68,6 @@ toType' tvs (CS.ListType ty)
= TypeConstructor (qualify listId) [toType' tvs ty]
toType' tvs (CS.ArrowType ty1 ty2)
= TypeArrow (toType' tvs ty1) (toType' tvs ty2)
toType' tvs (CS.RecordType fs)
= TypeRecord fs'
where
fs' = concatMap (\ (ls, ty) -> map (\ l -> (l, toType' tvs ty)) ls) fs
fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
fromQualType m = fromType . unqualifyType m
......@@ -90,8 +87,6 @@ fromType (TypeArrow ty1 ty2) =
CS.ArrowType (fromType ty1) (fromType ty2)
fromType (TypeSkolem k) =
CS.VariableType $ mkIdent $ "_?" ++ show k
fromType (TypeRecord fs) = CS.RecordType
(map (\ (l, ty) -> ([l], fromType ty)) fs)
-- The following functions implement pretty-printing for types.
ppType :: ModuleIdent -> Type -> Doc
......
......@@ -3,6 +3,7 @@
Description : Extraction of free and bound variables
Copyright : (c) Wolfgang Lux
2011 - 2012 Björn Peemöller
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -110,9 +111,8 @@ instance QualExpr Expression where
qfv m (Do sts e) = foldr (qfvStmt m) (qfv m e) sts
qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
qfv m (Case _ _ e alts) = qfv m e ++ qfv m alts
qfv m (RecordConstr fs) = qfv m fs
qfv m (RecordSelection e _) = qfv m e
qfv m (RecordUpdate fs e) = qfv m e ++ qfv m fs
qfv m (RecordConstr _ fs) = qfv m fs
qfv m (RecordUpdate e fs) = qfv m e ++ qfv m fs
qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident]
qfvStmt m st fvs = qfv m st ++ filterBv st fvs
......@@ -153,7 +153,7 @@ instance QuantExpr Pattern where
bv (LazyPattern _ t) = bv t
bv (FunctionPattern _ ts) = nub $ bv ts
bv (InfixFuncPattern t1 _ t2) = nub $ bv t1 ++ bv t2
bv (RecordPattern fs r) = maybe [] bv r ++ bv fs
bv (RecordPattern _ fs) = bv fs
instance QualExpr Pattern where
qfv _ (LiteralPattern _) = []
......@@ -170,7 +170,7 @@ instance QualExpr Pattern where
= maybe [] return (localIdent m f) ++ qfv m ts
qfv m (InfixFuncPattern t1 op t2)
= maybe [] return (localIdent m op) ++ qfv m [t1, t2]
qfv m (RecordPattern fs r) = maybe [] (qfv m) r ++ qfv m fs
qfv m (RecordPattern _ fs) = qfv m fs
instance Expr TypeExpr where
fv (ConstructorType _ tys) = fv tys
......@@ -180,7 +180,6 @@ instance Expr TypeExpr where
fv (TupleType tys) = fv tys
fv (ListType ty) = fv ty
fv (ArrowType ty1 ty2) = fv ty1 ++ fv ty2
fv (RecordType fs) = fv (map snd fs)
filterBv :: QuantExpr e => e -> [Ident] -> [Ident]
filterBv e = filter (`Set.notMember` Set.fromList (bv e))
......
......@@ -43,6 +43,7 @@ module Base.TopEnv
, bindTopEnv, qualBindTopEnv, rebindTopEnv
, qualRebindTopEnv, unbindTopEnv, lookupTopEnv, qualLookupTopEnv
, allImports, moduleImports, localBindings, allLocalBindings
, allEntities
) where
import Control.Arrow (second)
......@@ -161,3 +162,6 @@ localBindings env = [ (x, y) | (x, (Local, y)) <- unqualBindings env ]
allLocalBindings :: TopEnv a -> [(QualIdent, a)]
allLocalBindings (TopEnv env) = [ (x, y) | (x, ys) <- Map.toList env
, (Local, y) <- ys ]
allEntities :: TopEnv a -> [(QualIdent, a)]
allEntities env = [ (x, y) | (x, ys) <- Map.toList env, (_, y) <- ys]
\ No newline at end of file
......@@ -44,8 +44,6 @@ instance SubstType Type where
subst sigma (TypeArrow ty1 ty2) =
TypeArrow (subst sigma ty1) (subst sigma ty2)
subst _ ts@(TypeSkolem _) = ts
subst sigma (TypeRecord fs) = TypeRecord fs'
where fs' = map (\ (l,ty) -> (l, subst sigma ty)) fs
instance SubstType TypeScheme where
subst sigma (ForAll n ty) =
......@@ -82,8 +80,6 @@ expandAliasType _ (TypeConstrained tys n) = TypeConstrained tys n
expandAliasType tys (TypeArrow ty1 ty2) =
TypeArrow (expandAliasType tys ty1) (expandAliasType tys ty2)
expandAliasType _ tsk@(TypeSkolem _) = tsk
expandAliasType tys (TypeRecord fs) = TypeRecord fs'
where fs' = map (\ (l, ty) -> (l, expandAliasType tys ty)) fs
normalize :: Type -> Type
normalize ty = expandAliasType [TypeVariable (occur tv) | tv <- [0 ..]] ty
......
......@@ -3,6 +3,7 @@
Description : Internal representation of types
Copyright : (c) 2002 - 2004 Wolfgang Lux
Martin Engelke
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -57,7 +58,6 @@ data Type
| TypeArrow Type Type
| TypeConstrained [Type] Int
| TypeSkolem Int
| TypeRecord [(Ident, Type)]
deriving (Eq, Show)
-- The function 'isArrowType' checks whether a type is a function
......@@ -93,7 +93,6 @@ typeVars ty = vars ty [] where
vars (TypeConstrained _ _) tvs = tvs
vars (TypeArrow ty1 ty2) tvs = vars ty1 (vars ty2 tvs)
vars (TypeSkolem _) tvs = tvs
vars (TypeRecord fs) tvs = foldr vars tvs (map snd fs)
typeConstrs :: Type -> [QualIdent]
typeConstrs ty = constrs ty [] where
......@@ -102,7 +101,6 @@ typeConstrs ty = constrs ty [] where
constrs (TypeConstrained _ _) tcs = tcs
constrs (TypeArrow ty1 ty2) tcs = constrs ty1 (constrs ty2 tcs)
constrs (TypeSkolem _) tcs = tcs
constrs (TypeRecord fs) tcs = foldr constrs tcs (map snd fs)
typeSkolems :: Type -> [Int]
typeSkolems ty = skolems ty [] where
......@@ -111,7 +109,6 @@ typeSkolems ty = skolems ty [] where
skolems (TypeConstrained _ _) sks = sks
skolems (TypeArrow ty1 ty2) sks = skolems ty1 (skolems ty2 sks)
skolems (TypeSkolem k) sks = k : sks
skolems (TypeRecord fs) sks = foldr skolems sks (map snd fs)
-- The function 'equTypes' computes whether two types are equal modulo
-- renaming of type variables.
......@@ -134,8 +131,6 @@ equTypes t1 t2 = fst (equ [] t1 t2)
in (res1 && res2, is2)
equ is (TypeSkolem i1) (TypeSkolem i2)
= equVar is i1 i2
equ is (TypeRecord fs1) (TypeRecord fs2)
= equRecords is fs1 fs2
equ is _ _
= (False, is)
......@@ -143,15 +138,6 @@ equTypes t1 t2 = fst (equ [] t1 t2)
Nothing -> (True, (i1, i2) : is)
Just i2' -> (i2 == i2', is)
equRecords is fs1 fs2 | length fs1 == length fs2 = equrec is fs1 fs2
| otherwise = (False, is)
equrec is [] _ = (True, is)
equrec is ((l1, ty1) : fs1) fs2
= let (res1, is1) = maybe (False, is) (equ is ty1) (lookup l1 fs2)
(res2, is2) = equrec is1 fs1 fs2
in (res1 && res2, is2)
equs is [] [] = (True , is)
equs is (t1':ts1) (t2':ts2)
= let (res1, is1) = equ is t1' t2'
......@@ -177,8 +163,6 @@ qualifyType m (TypeConstrained tys tv) =
qualifyType m (TypeArrow ty1 ty2) =
TypeArrow (qualifyType m ty1) (qualifyType m ty2)
qualifyType _ skol@(TypeSkolem _) = skol
qualifyType m (TypeRecord fs) =
TypeRecord (map (\ (l, ty) -> (l, qualifyType m ty)) fs)
unqualifyType :: ModuleIdent -> Type -> Type
unqualifyType m (TypeConstructor tc tys) =
......@@ -189,16 +173,16 @@ unqualifyType m (TypeConstrained tys tv) =
unqualifyType m (TypeArrow ty1 ty2) =
TypeArrow (unqualifyType m ty1) (unqualifyType m ty2)
unqualifyType _ skol@(TypeSkolem _) = skol
unqualifyType m (TypeRecord fs) =
TypeRecord (map (\ (l, ty) -> (l, unqualifyType m ty)) fs)
-- The type 'DataConstr' is used to represent value constructors introduced
-- by data or newtype declarations.
-- The type 'DataConstr' is used to represent value or record constructors
-- introduced by data or newtype declarations.
data DataConstr = DataConstr Ident Int [Type]
| RecordConstr Ident Int [Ident] [Type]
deriving (Eq, Show)
constrIdent :: DataConstr -> Ident
constrIdent (DataConstr c _ _) = c
constrIdent (DataConstr c _ _) = c
constrIdent (RecordConstr c _ _ _) = c
-- We support two kinds of quantifications of types here, universally
-- quantified type schemes (forall alpha . tau(alpha)) and universally
......
module Checks.ExportCheck (exportCheck) where
import Control.Monad (liftM, unless)
import Control.Applicative ((<$>))
import Control.Monad (unless)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List (nub, union)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Maybe (catMaybes, fromMaybe)
import qualified Data.Set as Set
import Curry.Base.Ident
......@@ -31,7 +32,8 @@ exportCheck m aEnv tcEnv tyEnv spec = case expErrs of
[] -> (Just $ Exporting NoPos exports, ambiErrs)
ms -> (spec, ms)
where
(exports, expErrs) = runECM (joinExports `liftM` expandSpec spec) initState
(exports, expErrs) = runECM ((joinExports . canonExports tcEnv)
<$> expandSpec spec) initState
initState = ECState m imported tcEnv tyEnv []
imported = Set.fromList $ Map.elems aEnv
......@@ -71,9 +73,9 @@ report :: Message -> ECM ()
report err = S.modify (\ s -> s { errors = err : errors s })
-- While checking all export specifications, the compiler expands
-- specifications of the form @T(..)@ into @T(C_1,...,C_n)@,
-- where @C_1,...,C_n@ are the data constructors or the record labels of
-- type @T@, and replaces an export specification
-- specifications of the form @T(..)@ into @T(C_1,...,C_m,l_1,...,l_n)@,
-- where @C_1,...,C_m@ are the data constructors of type @T@ and @l_1,...,l_n@
-- its field labels, and replaces an export specification
-- @module M@ by specifications for all entities which are defined
-- in module @M@ and imported into the current module with their
-- unqualified name. In order to distinguish exported type constructors
......@@ -88,7 +90,7 @@ report err = S.modify (\ s -> s { errors = err : errors s })
-- |Expand export specification
expandSpec :: Maybe ExportSpec -> ECM [Export]
expandSpec Nothing = expandLocalModule
expandSpec (Just (Exporting _ es)) = concat `liftM` mapM expandExport es
expandSpec (Just (Exporting _ es)) = concat <$> mapM expandExport es
-- |Expand single export
expandExport :: Export -> ECM [Export]
......@@ -113,55 +115,89 @@ expandThing' f tcExport = do
case qualLookupValue f tyEnv of
[] -> justTcOr errUndefinedEntity
[Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport
[Label l _ _] -> return $ Export l : fromMaybe [] tcExport
[_] -> justTcOr errExportDataConstr
_ -> do
m <- getModuleIdent
case qualLookupValue (qualQualify m f) tyEnv of
[] -> justTcOr errUndefinedEntity
[Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport
[Label l _ _] -> return $ Export l : fromMaybe [] tcExport
[_] -> justTcOr errExportDataConstr
_ -> report (errAmbiguousName f) >> return []
where justTcOr errFun = case tcExport of
Nothing -> report (errFun f) >> return []
Just tc -> return tc
-- |Expand type constructor with explicit data constructors
-- |Expand type constructor with explicit data constructors and record labels
expandTypeWith :: QualIdent -> [Ident] -> ECM [Export]
expandTypeWith tc cs = do
expandTypeWith tc xs = do
tcEnv <- getTyConsEnv
case qualLookupTC tc tcEnv of
[] -> report (errUndefinedType tc) >> return []
[t] | isDataType t -> do mapM_ (checkConstr $ constrs t) nubCons
return [ExportTypeWith (origName t) nubCons]
| isRecordType t -> do mapM_ (checkLabel $ labels t) nubCons
return [ExportTypeWith (origName t)
(map renameLabel nubCons)]
| otherwise -> report (errNonDataType tc) >> return []
_ -> report (errAmbiguousType tc) >> return []
[t@(DataType _ _ cs)] -> do
mapM_ (checkElement (concatMap visibleElems (catMaybes cs))) xs'
return [ExportTypeWith (origName t) xs']
[t@(RenamingType _ _ c)] -> do
mapM_ (checkElement (visibleElems c)) xs'
return [ExportTypeWith (origName t) xs']
[_] -> report (errNonDataType tc) >> return []
_ -> report (errAmbiguousType tc) >> return []
where
nubCons = nub cs
checkConstr cs' c = unless (c `elem` cs')
(report $ errUndefinedDataConstr tc c)
checkLabel ls l = unless (renameLabel l `elem` ls)
(report $ errUndefinedLabel tc l)
xs' = nub xs
-- check if given identifier is constructor or label of type tc
checkElement cs' c = do
unless (c `elem` cs') $ report $ errUndefinedElement tc c
return c
-- |Expand type constructor with all data constructors
-- |Expand type constructor with explicit data constructors
-- expandTypeWith :: QualIdent -> [Ident] -> ECM [Export]
-- expandTypeWith tc cs = do
-- tcEnv <- getTyConsEnv
-- case qualLookupTC tc tcEnv of
-- [] -> report (errUndefinedType tc) >> return []
-- [t] | isDataType t -> do mapM_ (checkConstr $ constrs t) nubCons
-- return [ExportTypeWith (origName t) nubCons]
-- | isRecordType t -> do mapM_ (checkLabel $ labels t) nubCons
-- return [ExportTypeWith (origName t)
-- (map renameLabel nubCons)]
-- | otherwise -> report (errNonDataType tc) >> return []
-- _ -> report (errAmbiguousType tc) >> return []
-- where
-- nubCons = nub cs
-- checkConstr cs' c = unless (c `elem` cs')
-- (report $ errUndefinedDataConstr tc c)
-- checkLabel ls l = unless (renameLabel l `elem` ls)
-- (report $ errUndefinedLabel tc l)
-- |Expand type constructor with all data constructors and record labels
expandTypeAll :: QualIdent -> ECM [Export]
expandTypeAll tc = do
tcEnv <- getTyConsEnv
case qualLookupTC tc tcEnv of
[] -> report (errUndefinedType tc) >> return []
[t] -> do
tyEnv <- getValueEnv
if isDataType t || isRecordType t
then return [exportType tyEnv t]
else report (errNonDataType tc) >> return []
[] -> report (errUndefinedType tc) >> return []
[t@(DataType _ _ _)] -> return $ [exportType t]
[t@(RenamingType _ _ _)] -> return $ [exportType t]
[_] -> report (errNonDataType tc) >> return []
_ -> report (errAmbiguousType tc) >> return []
-- |Expand type constructor with all data constructors
-- expandTypeAll :: QualIdent -> ECM [Export]
-- expandTypeAll tc = do
-- tcEnv <- getTyConsEnv
-- case qualLookupTC tc tcEnv of
-- [] -> report (errUndefinedType tc) >> return []
-- [t] -> do
-- tyEnv <- getValueEnv
-- if isDataType t || isRecordType t
-- then return [exportType tyEnv t]
-- else report (errNonDataType tc) >> return []
-- _ -> report (errAmbiguousType tc) >> return []
expandModule :: ModuleIdent -> ECM [Export]
expandModule em = do
isLocal <- (em ==) `liftM` getModuleIdent
isForeign <- (Set.member em) `liftM` getImportedModules
isLocal <- (em ==) <$> getModuleIdent
isForeign <- (Set.member em) <$> getImportedModules
locals <- if isLocal then expandLocalModule else return []
foreigns <- if isForeign then expandImportedModule em else return []
unless (isLocal || isForeign) $ report $ errModuleNotImported em
......@@ -171,30 +207,69 @@ expandLocalModule :: ECM [Export]
expandLocalModule = do
tcEnv <- getTyConsEnv
tyEnv <- getValueEnv
return $ [exportType tyEnv t | (_, t) <- localBindings tcEnv] ++
[Export f' | (f, Value f' _ _) <- localBindings tyEnv, f == unRenameIdent f]
return $ [exportType t | (_, t) <- localBindings tcEnv] ++
[ Export f' | (f, Value f' _ _) <- localBindings tyEnv
, f == unRenameIdent f] ++
[ Export l' | (l, Label l' _ _) <- localBindings tyEnv
, l == unRenameIdent l]
-- |Expand a module export
expandImportedModule :: ModuleIdent -> ECM [Export]
expandImportedModule m = do
tcEnv <- getTyConsEnv
tyEnv <- getValueEnv
return $ [exportType tyEnv t | (_, t) <- moduleImports m tcEnv]
return $ [exportType t | (_, t) <- moduleImports m tcEnv]
++ [Export f | (_, Value f _ _) <- moduleImports m tyEnv]
exportType :: ValueEnv -> TypeInfo -> Export
exportType tyEnv t
| isRecordType t
= let ls = labels t
r = origName t
in case lookupValue (head ls) tyEnv of
[Label _ r' _] -> if r == r' then ExportTypeWith r ls
else ExportTypeWith r []
_ -> internalError "Exports.exportType"
| otherwise = ExportTypeWith (origName t) (constrs t)
++ [Export l | (_, Label l _ _) <- moduleImports m tyEnv]
exportType :: TypeInfo -> Export
exportType t = ExportTypeWith tc xs
where tc = origName t
xs = elements t
-- exportType :: ValueEnv -> TypeInfo -> Export
-- exportType tyEnv t
-- | isRecordType t
-- = let ls = labels t
-- r = origName t
-- in case lookupValue (head ls) tyEnv of
-- [Label _ r' _] -> if r == r' then ExportTypeWith r ls
-- else ExportTypeWith r []
-- _ -> internalError "Exports.exportType"
-- | otherwise = ExportTypeWith (origName t) (constrs t)
-- For compatibility with Haskell, we allow exporting field labels but
-- not constructors individually as well as together with their types.
-- Thus, given the declaration @data T a = C { l :: a }@
-- the export lists @(T(C,l))@ and @(T(C),l)@ are equivalent and both
-- export the constructor @C@ and the field label @l@ together with the
-- type @T@. However, it is also possible to export the label @l@
-- without exporting its type @T@. In this case, the label is exported
-- just like a top-level function (namely the implicit record selection
-- function corresponding to the label). In order to avoid ambiguities
-- in the interface, we convert an individual export of a label @l@ into
-- the form @T(l)@ whenever its type @T@ occurs in the export list as well.
canonExports :: [Export] -> [Export]
canonExports es = map (canonExport (canonLabels tcEnv es)) es
canonExport :: Map.Map QualIdent Export -> Export -> Export
canonExport ls (Export x) = fromMaybe (Export x) (Map.lookup x ls)
canonExport _ (ExportTypeWith tc xs) = ExportTypeWith tc xs
canonLabels :: TCEnv -> [Export] -> Map.Map QualIdent Export
canonLabels tcEnv es = foldr bindLabels Map.empty (allEntities tcEnv)
where tcs = [tc | ExportTypeWith tc _ <- es]
bindLabels t ls
| tc `elem` tcs = foldr (bindLabel tc) ls (elements t)
| otherwise = ls
where tc = origName t
bindLabel tc x = Map.insert (qualifyLike tc x) (ExportTypeWith tc [x])
-- The expanded list of exported entities may contain duplicates. These
-- are removed by the function joinExports. In particular, this
-- function removes any field labels from the list of exported values
-- which are also exported along with their types.
joinExports :: [Export] -> [Export]
joinExports es = [ExportTypeWith tc cs | (tc, cs) <- joinedTypes]
......@@ -218,23 +293,20 @@ joinFun export _ = internalError $
-- Auxiliary definitions
-- ---------------------------------------------------------------------------
constrs :: TypeInfo -> [Ident]
constrs (DataType _ _ cs) = [c | Just (DataConstr c _ _) <- cs]
constrs (RenamingType _ _ (DataConstr c _ _)) = [c]
constrs (AliasType _ _ _) = []
labels :: TypeInfo -> [Ident]
labels (AliasType _ _ (TypeRecord fs)) = map fst fs
labels _ = []
-- constrs :: TypeInfo -> [Ident]
-- constrs (DataType _ _ cs) = [c | Just (DataConstr c _ _) <- cs]
-- constrs (RenamingType _ _ (DataConstr c _ _)) = [c]
-- constrs (AliasType _ _ _) = []
isDataType :: TypeInfo -> Bool
isDataType (DataType _ _ _) = True
isDataType (RenamingType _ _ _) = True
isDataType (AliasType _ _ _) = False
elements :: TypeInfo -> [Ident]
elements (DataType _ _ cs) = concatMap visibleElems $ catMaybes cs
elements (RenamingType _ _ c) = visibleElems c
elements (AliasType _ _ _) = []
isRecordType :: TypeInfo -> Bool
isRecordType (AliasType _ _ (TypeRecord _)) = True
isRecordType _ = False
-- get visible constructor and label identifiers for given constructor
visibleElems :: DataConstr -> [Ident]
visibleElems (DataConstr c _ _) = [c]
visibleElems (RecordConstr c _ ls _) = c : ls
-- ---------------------------------------------------------------------------
-- Error messages
......@@ -247,6 +319,10 @@ errUndefinedEntity x = posMessage x $ hsep $ map text
errUndefinedType :: QualIdent -> Message
errUndefinedType tc = posMessage tc $ hsep $ map text
["Type", qualName tc, "in export list is not defined"]
errUndefinedElement :: Ident -> Ident -> Message
errUndefinedElement tc c = posMessage c $ hsep $ map text
[ idName c, "is not a constructor or label of type ", idName tc ]
errModuleNotImported :: ModuleIdent -> Message
errModuleNotImported m = posMessage m $ hsep $ map text
......@@ -284,10 +360,10 @@ errNonDataType :: QualIdent -> Message
errNonDataType tc = posMessage tc $ hsep $ map text
[qualName tc, "is not a data type"]
errUndefinedDataConstr :: QualIdent -> Ident -> Message
errUndefinedDataConstr tc c = posMessage c $ hsep $ map text
[idName c, "is not a data constructor of type", qualName tc]
-- errUndefinedDataConstr :: QualIdent -> Ident -> Message
-- errUndefinedDataConstr tc c = posMessage c $ hsep $ map text
-- [idName c, "is not a data constructor of type", qualName tc]
errUndefinedLabel :: QualIdent -> Ident -> Message
errUndefinedLabel r l = posMessage l $ hsep $ map text
[idName l, "is not a label of the record", qualName r]
-- errUndefinedLabel :: QualIdent -> Ident -> Message
-- errUndefinedLabel r l = posMessage l $ hsep $ map text
-- [idName l, "is not a label of the record", qualName r]
......@@ -2,6 +2,7 @@
Module : $Header$
Description : Checks consistency of interface files
Copyright : (c) 2000 - 2007 Wolfgang Lux
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -106,30 +107,24 @@ checkImport (HidingDataDecl p tc tvs)
| tc == tc' && length tvs == n' = Just ok
check (RenamingType tc' n' _)
| tc == tc' && length tvs == n' = Just ok
check (AliasType tc' n' (TypeRecord _))
| tc == tc' && length tvs == n' = Just ok
check _ = Nothing
checkImport (IDataDecl p tc tvs cs) = checkTypeInfo "data type" check p tc
checkImport (IDataDecl p tc tvs cs hs) = 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'))
= Just (mapM_ (checkConstrImport tc tvs) (catMaybes cs))
= Just (mapM_ (checkConstrImport tc tvs) cs)
check (RenamingType tc' n' _)
| tc == tc' && length tvs == n' && null cs = Just ok
check _ = Nothing
isVisible (Just c) (Just c') = constr c == c'
isVisible (Just _) Nothing = False
isVisible Nothing _ = True
constr (ConstrDecl _ _ c _) = c
constr (ConOpDecl _ _ _ op _) = op
checkImport (INewtypeDecl p tc tvs nc)
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')
| tc == tc' && length tvs == n' && nconstr nc == constrIdent nc'
| tc == tc' && length tvs == n' && nconstrId nc == constrIdent nc'
= Just (checkNewConstrImport tc tvs nc)
check _ = Nothing
nconstr (NewConstrDecl _ _ c _) = c
checkImport (ITypeDecl p tc tvs ty) = do
m <- getModuleIdent
let check (AliasType tc' n' ty')
......@@ -148,7 +143,7 @@ checkConstrImport :: QualIdent -> [Ident] -> ConstrDecl -> IC ()
checkConstrImport tc tvs (ConstrDecl p evs c tys) = do
m <- getModuleIdent
let qc = qualifyLike tc c
checkConstr (DataConstructor c' _ (ForAllExist uqvs eqvs ty')) =
checkConstr (DataConstructor c' _ _ (ForAllExist uqvs eqvs ty')) =
qc == c' && length evs == eqvs && length tvs == uqvs &&
toQualTypes m tvs tys == arrowArgs ty'
checkConstr _ = False
......@@ -156,19 +151,36 @@ checkConstrImport tc tvs (ConstrDecl p evs c tys) = do
checkConstrImport tc tvs (ConOpDecl p evs ty1 op ty2) = do
m <- getModuleIdent
let qc = qualifyLike tc op
checkConstr (DataConstructor c' _ (ForAllExist uqvs eqvs ty')) =
checkConstr (DataConstructor c' _ _ (ForAllExist uqvs eqvs ty')) =
qc == c' && length evs == eqvs && length tvs == uqvs &&
toQualTypes m tvs [ty1,ty2] == arrowArgs ty'
checkConstr _ = False
checkValueInfo "data constructor" checkConstr p qc
checkConstrImport tc tvs (RecordDecl p evs c fs) = do
m <- getModuleIdent
let qc = qualifyLike tc c
(ls, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]
checkConstr (DataConstructor c' _ ls' (ForAllExist uqvs eqvs ty')) =
qc == c' && length evs == eqvs && length tvs == uqvs && ls == ls' &&
toQualTypes m tvs tys == arrowArgs ty'
checkConstr _ = False
checkValueInfo "data constructor" checkConstr p qc
checkNewConstrImport :: QualIdent -> [Ident] -> NewConstrDecl -> IC ()
checkNewConstrImport tc tvs (NewConstrDecl p evs c ty) = do
m <- getModuleIdent
let qc = qualifyLike tc c
checkNewConstr (NewtypeConstructor c' (ForAllExist uqvs eqvs ty')) =
qc == c' && length evs == eqvs && length tvs == uqvs &&
toQualType m tvs ty == head (arrowArgs ty')
checkNewConstr (NewtypeConstructor c' _ (ForAllExist uqvs eqvs ty')) =
qc == c' && length evs == eqvs && length tvs == uqvs &&
toQualType m tvs ty == head (arrowArgs ty')
checkNewConstr _ = False
checkValueInfo "newtype constructor" checkNewConstr p qc
checkNewConstrImport tc tvs (NewRecordDecl p evs c (l, ty)) = do
m <- getModuleIdent
let qc = qualifyLike tc c