Commit 69d91016 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Make frontend compile again

parent 78887d02
...@@ -94,6 +94,8 @@ instance QualExpr Expression where ...@@ -94,6 +94,8 @@ instance QualExpr Expression where
qfv _ (Constructor _) = [] qfv _ (Constructor _) = []
qfv m (Paren e) = qfv m e qfv m (Paren e) = qfv m e
qfv m (Typed e _) = qfv m e qfv m (Typed e _) = qfv m e
qfv m (Record _ fs) = qfv m fs
qfv m (RecordUpdate e fs) = qfv m e ++ qfv m fs
qfv m (Tuple _ es) = qfv m es qfv m (Tuple _ es) = qfv m es
qfv m (List _ es) = qfv m es qfv m (List _ es) = qfv m es
qfv m (ListCompr _ e qs) = foldr (qfvStmt m) (qfv m e) qs qfv m (ListCompr _ e qs) = foldr (qfvStmt m) (qfv m e) qs
...@@ -111,8 +113,6 @@ instance QualExpr Expression where ...@@ -111,8 +113,6 @@ instance QualExpr Expression where
qfv m (Do sts e) = foldr (qfvStmt m) (qfv m e) sts 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 (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 (Case _ _ e alts) = qfv m e ++ qfv m alts
qfv m (RecordConstr _ fs) = qfv m fs
qfv m (RecordUpdate e fs) = qfv m e ++ qfv m fs
qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident] qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident]
qfvStmt m st fvs = qfv m st ++ filterBv st fvs qfvStmt m st fvs = qfv m st ++ filterBv st fvs
...@@ -147,13 +147,13 @@ instance QuantExpr Pattern where ...@@ -147,13 +147,13 @@ instance QuantExpr Pattern where
bv (ConstructorPattern _ ts) = bv ts bv (ConstructorPattern _ ts) = bv ts
bv (InfixPattern t1 _ t2) = bv t1 ++ bv t2 bv (InfixPattern t1 _ t2) = bv t1 ++ bv t2
bv (ParenPattern t) = bv t bv (ParenPattern t) = bv t
bv (RecordPattern _ fs) = bv fs
bv (TuplePattern _ ts) = bv ts bv (TuplePattern _ ts) = bv ts
bv (ListPattern _ ts) = bv ts bv (ListPattern _ ts) = bv ts
bv (AsPattern v t) = v : bv t bv (AsPattern v t) = v : bv t
bv (LazyPattern _ t) = bv t bv (LazyPattern _ t) = bv t
bv (FunctionPattern _ ts) = nub $ bv ts bv (FunctionPattern _ ts) = nub $ bv ts
bv (InfixFuncPattern t1 _ t2) = nub $ bv t1 ++ bv t2 bv (InfixFuncPattern t1 _ t2) = nub $ bv t1 ++ bv t2
bv (RecordPattern _ fs) = bv fs
instance QualExpr Pattern where instance QualExpr Pattern where
qfv _ (LiteralPattern _) = [] qfv _ (LiteralPattern _) = []
...@@ -162,6 +162,7 @@ instance QualExpr Pattern where ...@@ -162,6 +162,7 @@ instance QualExpr Pattern where
qfv m (ConstructorPattern _ ts) = qfv m ts qfv m (ConstructorPattern _ ts) = qfv m ts
qfv m (InfixPattern t1 _ t2) = qfv m [t1, t2] qfv m (InfixPattern t1 _ t2) = qfv m [t1, t2]
qfv m (ParenPattern t) = qfv m t qfv m (ParenPattern t) = qfv m t
qfv m (RecordPattern _ fs) = qfv m fs
qfv m (TuplePattern _ ts) = qfv m ts qfv m (TuplePattern _ ts) = qfv m ts
qfv m (ListPattern _ ts) = qfv m ts qfv m (ListPattern _ ts) = qfv m ts
qfv m (AsPattern _ ts) = qfv m ts qfv m (AsPattern _ ts) = qfv m ts
...@@ -170,7 +171,6 @@ instance QualExpr Pattern where ...@@ -170,7 +171,6 @@ instance QualExpr Pattern where
= maybe [] return (localIdent m f) ++ qfv m ts = maybe [] return (localIdent m f) ++ qfv m ts
qfv m (InfixFuncPattern t1 op t2) qfv m (InfixFuncPattern t1 op t2)
= maybe [] return (localIdent m op) ++ qfv m [t1, t2] = maybe [] return (localIdent m op) ++ qfv m [t1, t2]
qfv m (RecordPattern _ fs) = qfv m fs
instance Expr TypeExpr where instance Expr TypeExpr where
fv (ConstructorType _ tys) = fv tys fv (ConstructorType _ tys) = fv tys
......
...@@ -163,5 +163,5 @@ allLocalBindings :: TopEnv a -> [(QualIdent, a)] ...@@ -163,5 +163,5 @@ allLocalBindings :: TopEnv a -> [(QualIdent, a)]
allLocalBindings (TopEnv env) = [ (x, y) | (x, ys) <- Map.toList env allLocalBindings (TopEnv env) = [ (x, y) | (x, ys) <- Map.toList env
, (Local, y) <- ys ] , (Local, y) <- ys ]
allEntities :: TopEnv a -> [(QualIdent, a)] allEntities :: TopEnv a -> [a]
allEntities env = [ (x, y) | (x, ys) <- Map.toList env, (_, y) <- ys] allEntities (TopEnv env) = [ y | (_, ys) <- Map.toList env, (_, y) <- ys]
...@@ -54,10 +54,10 @@ instance SubstType ExistTypeScheme where ...@@ -54,10 +54,10 @@ instance SubstType ExistTypeScheme where
ForAllExist n n' (subst (foldr unbindSubst sigma [0..n+n'-1]) ty) ForAllExist n n' (subst (foldr unbindSubst sigma [0..n+n'-1]) ty)
instance SubstType ValueInfo where instance SubstType ValueInfo where
subst _ dc@(DataConstructor _ _ _) = dc subst _ dc@(DataConstructor _ _ _ _) = dc
subst _ nc@(NewtypeConstructor _ _) = nc subst _ nc@(NewtypeConstructor _ _ _) = nc
subst theta (Value v a ty) = Value v a (subst theta ty) subst theta (Value v a ty) = Value v a (subst theta ty)
subst theta (Label l r ty) = Label l r (subst theta ty) subst theta (Label l r ty) = Label l r (subst theta ty)
instance SubstType a => SubstType (TopEnv a) where instance SubstType a => SubstType (TopEnv a) where
subst = fmap . subst subst = fmap . subst
......
...@@ -21,7 +21,8 @@ module Base.Types ...@@ -21,7 +21,8 @@ module Base.Types
Type (..), isArrowType, arrowArity, arrowArgs, arrowBase, arrowUnapply Type (..), isArrowType, arrowArity, arrowArgs, arrowBase, arrowUnapply
, typeVars, typeConstrs, typeSkolems, equTypes, qualifyType, unqualifyType , typeVars, typeConstrs, typeSkolems, equTypes, qualifyType, unqualifyType
-- * Representation of Data Constructors -- * Representation of Data Constructors
, DataConstr (..), constrIdent, tupleData , DataConstr (..), constrIdent, constrTypes, recLabels, recLabelTypes
, tupleData
-- * Representation of Quantification -- * Representation of Quantification
, TypeScheme (..), ExistTypeScheme (..), monoType, polyType , TypeScheme (..), ExistTypeScheme (..), monoType, polyType
-- * Predefined types -- * Predefined types
...@@ -180,7 +181,7 @@ unqualifyType _ skol@(TypeSkolem _) = skol ...@@ -180,7 +181,7 @@ unqualifyType _ skol@(TypeSkolem _) = skol
-- The type 'DataConstr' is used to represent value or record constructors -- The type 'DataConstr' is used to represent value or record constructors
-- introduced by data or newtype declarations. -- introduced by data or newtype declarations.
data DataConstr = DataConstr Ident Int [Type] data DataConstr = DataConstr Ident Int [Type]
| RecordConstr Ident Int [Ident] [Type] | RecordConstr Ident Int [Ident] [Type]
deriving (Eq, Show) deriving (Eq, Show)
...@@ -188,6 +189,18 @@ constrIdent :: DataConstr -> Ident ...@@ -188,6 +189,18 @@ constrIdent :: DataConstr -> Ident
constrIdent (DataConstr c _ _) = c constrIdent (DataConstr c _ _) = c
constrIdent (RecordConstr c _ _ _) = c constrIdent (RecordConstr c _ _ _) = c
constrTypes :: DataConstr -> [Type]
constrTypes (DataConstr _ _ ty) = ty
constrTypes (RecordConstr _ _ _ ty) = ty
recLabels :: DataConstr -> [Ident]
recLabels (DataConstr _ _ _) = []
recLabels (RecordConstr _ _ ls _) = ls
recLabelTypes :: DataConstr -> [Type]
recLabelTypes (DataConstr _ _ _) = []
recLabelTypes (RecordConstr _ _ _ tys) = tys
-- We support two kinds of quantifications of types here, universally -- We support two kinds of quantifications of types here, universally
-- quantified type schemes (forall alpha . tau(alpha)) and universally -- quantified type schemes (forall alpha . tau(alpha)) and universally
-- and existentially quantified type schemes -- and existentially quantified type schemes
......
...@@ -11,7 +11,7 @@ ...@@ -11,7 +11,7 @@
-} -}
module Base.Typing (Typeable (..), argumentTypes) where module Base.Typing (Typeable (..)) where
import Control.Monad import Control.Monad
import qualified Control.Monad.State as S (State, evalState, gets, modify) import qualified Control.Monad.State as S (State, evalState, gets, modify)
...@@ -25,9 +25,7 @@ import Base.Types ...@@ -25,9 +25,7 @@ import Base.Types
import Base.TypeSubst import Base.TypeSubst
import Base.Utils (foldr2) import Base.Utils (foldr2)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC) import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue
, conType)
-- During the transformation of Curry source code into the intermediate -- During the transformation of Curry source code into the intermediate
-- language, the compiler has to recompute the types of expressions. This -- language, the compiler has to recompute the types of expressions. This
...@@ -92,16 +90,12 @@ import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue ...@@ -92,16 +90,12 @@ import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue
data TcState = TcState data TcState = TcState
{ valueEnv :: ValueEnv { valueEnv :: ValueEnv
, tyConsEnv :: TCEnv
, typeSubst :: TypeSubst , typeSubst :: TypeSubst
, nextId :: Int , nextId :: Int
} }
type TCM = S.State TcState type TCM = S.State TcState
getTyConsEnv :: TCM TCEnv
getTyConsEnv = S.gets tyConsEnv
getValueEnv :: TCM ValueEnv getValueEnv :: TCM ValueEnv
getValueEnv = S.gets valueEnv getValueEnv = S.gets valueEnv
...@@ -117,12 +111,12 @@ getNextId = do ...@@ -117,12 +111,12 @@ getNextId = do
S.modify $ \ s -> s { nextId = succ nid } S.modify $ \ s -> s { nextId = succ nid }
return nid return nid
run :: TCM a -> ValueEnv -> TCEnv -> a run :: TCM a -> ValueEnv -> a
run m tyEnv tcEnv = S.evalState m initState run m tyEnv = S.evalState m initState
where initState = TcState tyEnv tcEnv idSubst 0 where initState = TcState tyEnv idSubst 0
class Typeable a where class Typeable a where
typeOf :: ValueEnv -> TCEnv -> a -> Type typeOf :: ValueEnv -> a -> Type
instance Typeable Ident where instance Typeable Ident where
typeOf = computeType identType typeOf = computeType identType
...@@ -136,8 +130,8 @@ instance Typeable Expression where ...@@ -136,8 +130,8 @@ instance Typeable Expression where
instance Typeable Rhs where instance Typeable Rhs where
typeOf = computeType rhsType typeOf = computeType rhsType
computeType :: (a -> TCM Type) -> ValueEnv -> TCEnv -> a -> Type computeType :: (a -> TCM Type) -> ValueEnv -> a -> Type
computeType f tyEnv tcEnv x = normalize (run doComputeType tyEnv tcEnv) computeType f tyEnv x = normalize (run doComputeType tyEnv)
where where
doComputeType = do doComputeType = do
ty <- f x ty <- f x
...@@ -276,7 +270,7 @@ rhsType (GuardedRhs es _) = freshTypeVar >>= flip condExprType es ...@@ -276,7 +270,7 @@ rhsType (GuardedRhs es _) = freshTypeVar >>= flip condExprType es
fieldType :: (a -> TCM Type) -> Type -> Field a -> TCM Type fieldType :: (a -> TCM Type) -> Type -> Field a -> TCM Type
fieldType tcheck ty (Field _ l x) = do fieldType tcheck ty (Field _ l x) = do
tyEnv <- getValueEnv tyEnv <- getValueEnv
TypeArrow ty1 ty2 <- instType (labelType l tyEnv) TypeArrow ty1 ty2 <- instUniv (labelType l tyEnv)
unify ty ty1 unify ty ty1
lty <- tcheck x lty <- tcheck x
unify ty2 lty unify ty2 lty
...@@ -294,11 +288,6 @@ instType n ty = do ...@@ -294,11 +288,6 @@ instType n ty = do
tys <- replicateM n freshTypeVar tys <- replicateM n freshTypeVar
return (expandAliasType tys ty) return (expandAliasType tys ty)
instType' :: Int -> Type -> TCM (Type,[Type])
instType' n ty = do
tys <- replicateM n freshTypeVar
return (expandAliasType tys ty, tys)
instUniv :: TypeScheme -> TCM Type instUniv :: TypeScheme -> TCM Type
instUniv (ForAll n ty) = instType n ty instUniv (ForAll n ty) = instType n ty
...@@ -357,24 +346,6 @@ unifyTypes (TypeSkolem k1) (TypeSkolem k2) theta ...@@ -357,24 +346,6 @@ unifyTypes (TypeSkolem k1) (TypeSkolem k2) theta
unifyTypes ty1 ty2 _ = internalError $ unifyTypes ty1 ty2 _ = internalError $
"Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")" "Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")"
-- The function argumentTypes returns the labels and the argument types
-- of a data constructor instantiated at a particular type. This
-- function is useful for desugaring record patterns and expressions,
-- where the compiler must compute the types of the omitted arguments.
-- Since the type annotation of record patterns and expressions applies
-- to the pattern or expression as a whole, the instance type is
-- unified with the constructor's result type and the resulting
-- substitution is applied to all argument types. Note that this is
-- sound because record fields cannot have existentially quantified
-- types and therefore all type variables appearing in their
-- types occur in the constructor's result type as well.
argumentTypes :: TCEnv -> Type -> QualIdent -> ValueEnv -> ([Ident],[Type])
argumentTypes tcEnv ty c tyEnv =
(ls, map (subst (unifyTypes rty ty idSubst)) tys)
where (ls, ForAllExist _ _ ty') = conType c tyEnv
(tys, rty) = arrowUnapply ty'
-- The functions 'constrType', 'varType', and 'funType' are used for computing -- The functions 'constrType', 'varType', and 'funType' are used for computing
-- the type of constructors, pattern variables, and variables. -- the type of constructors, pattern variables, and variables.
...@@ -396,7 +367,7 @@ funType f tyEnv = case qualLookupValue f tyEnv of ...@@ -396,7 +367,7 @@ funType f tyEnv = case qualLookupValue f tyEnv of
[Value _ _ sigma] -> sigma [Value _ _ sigma] -> sigma
_ -> internalError $ "Base.Typing.funType: " ++ show f _ -> internalError $ "Base.Typing.funType: " ++ show f
labelType :: Ident -> ValueEnv -> TypeScheme labelType :: QualIdent -> ValueEnv -> TypeScheme
labelType l tyEnv = case lookupValue l tyEnv of labelType l tyEnv = case qualLookupValue l tyEnv of
[Label _ _ sigma] -> sigma [Label _ _ sigma] -> sigma
_ -> internalError $ "Base.Typing.labelType: " ++ show l _ -> internalError $ "Base.Typing.labelType: " ++ show l
...@@ -57,8 +57,7 @@ syntaxCheck :: Monad m => Check m Module ...@@ -57,8 +57,7 @@ syntaxCheck :: Monad m => Check m Module
syntaxCheck opts (env, mdl) syntaxCheck opts (env, mdl)
| null msgs = ok (env { extensions = exts }, mdl') | null msgs = ok (env { extensions = exts }, mdl')
| otherwise = failMessages msgs | otherwise = failMessages msgs
where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env) where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env) mdl
(tyConsEnv env) mdl
-- |Check the precedences of infix operators. -- |Check the precedences of infix operators.
-- --
......
...@@ -5,7 +5,7 @@ import Control.Monad (unless) ...@@ -5,7 +5,7 @@ import Control.Monad (unless)
import qualified Control.Monad.State as S (State, runState, gets, modify) import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List (nub, union) import Data.List (nub, union)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Set as Set import qualified Data.Set as Set
import Curry.Base.Ident import Curry.Base.Ident
...@@ -136,7 +136,7 @@ expandTypeWith tc xs = do ...@@ -136,7 +136,7 @@ expandTypeWith tc xs = do
case qualLookupTC tc tcEnv of case qualLookupTC tc tcEnv of
[] -> report (errUndefinedType tc) >> return [] [] -> report (errUndefinedType tc) >> return []
[t@(DataType _ _ cs)] -> do [t@(DataType _ _ cs)] -> do
mapM_ (checkElement (concatMap visibleElems (catMaybes cs))) xs' mapM_ (checkElement (concatMap visibleElems cs)) xs'
return [ExportTypeWith (origName t) xs'] return [ExportTypeWith (origName t) xs']
[t@(RenamingType _ _ c)] -> do [t@(RenamingType _ _ c)] -> do
mapM_ (checkElement (visibleElems c)) xs' mapM_ (checkElement (visibleElems c)) xs'
...@@ -250,21 +250,25 @@ exportType t = ExportTypeWith tc xs ...@@ -250,21 +250,25 @@ exportType t = ExportTypeWith tc xs
-- in the interface, we convert an individual export of a label @l@ into -- 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. -- the form @T(l)@ whenever its type @T@ occurs in the export list as well.
canonExports :: [Export] -> [Export] canonExports :: TCEnv -> [Export] -> [Export]
canonExports es = map (canonExport (canonLabels tcEnv es)) es canonExports tcEnv es = map (canonExport (canonLabels tcEnv es)) es
canonExport :: Map.Map QualIdent Export -> Export -> Export canonExport :: Map.Map QualIdent Export -> Export -> Export
canonExport ls (Export x) = fromMaybe (Export x) (Map.lookup x ls) canonExport ls (Export x) = fromMaybe (Export x) (Map.lookup x ls)
canonExport _ (ExportTypeWith tc xs) = ExportTypeWith tc xs canonExport _ (ExportTypeWith tc xs) = ExportTypeWith tc xs
canonExport _ e = internalError $
"Checks.ExportCheck.canonExport: " ++ show e
canonLabels :: TCEnv -> [Export] -> Map.Map QualIdent Export canonLabels :: TCEnv -> [Export] -> Map.Map QualIdent Export
canonLabels tcEnv es = foldr bindLabels Map.empty (allEntities tcEnv) canonLabels tcEnv es = foldr bindLabels Map.empty (allEntities tcEnv)
where tcs = [tc | ExportTypeWith tc _ <- es] where
bindLabels t ls tcs = [tc | ExportTypeWith tc _ <- es]
| tc `elem` tcs = foldr (bindLabel tc) ls (elements t) bindLabels t ls
| otherwise = ls | tc' `elem` tcs = foldr (bindLabel tc') ls (elements t)
where tc = origName t | otherwise = ls
bindLabel tc x = Map.insert (qualifyLike tc x) (ExportTypeWith tc [x]) 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 -- The expanded list of exported entities may contain duplicates. These
-- are removed by the function joinExports. In particular, this -- are removed by the function joinExports. In particular, this
...@@ -299,7 +303,7 @@ joinFun export _ = internalError $ ...@@ -299,7 +303,7 @@ joinFun export _ = internalError $
-- constrs (AliasType _ _ _) = [] -- constrs (AliasType _ _ _) = []
elements :: TypeInfo -> [Ident] elements :: TypeInfo -> [Ident]
elements (DataType _ _ cs) = concatMap visibleElems $ catMaybes cs elements (DataType _ _ cs) = concatMap visibleElems cs
elements (RenamingType _ _ c) = visibleElems c elements (RenamingType _ _ c) = visibleElems c
elements (AliasType _ _ _) = [] elements (AliasType _ _ _) = []
...@@ -320,9 +324,9 @@ errUndefinedType :: QualIdent -> Message ...@@ -320,9 +324,9 @@ errUndefinedType :: QualIdent -> Message
errUndefinedType tc = posMessage tc $ hsep $ map text errUndefinedType tc = posMessage tc $ hsep $ map text
["Type", qualName tc, "in export list is not defined"] ["Type", qualName tc, "in export list is not defined"]
errUndefinedElement :: Ident -> Ident -> Message errUndefinedElement :: QualIdent -> Ident -> Message
errUndefinedElement tc c = posMessage c $ hsep $ map text errUndefinedElement tc c = posMessage c $ hsep $ map text
[ idName c, "is not a constructor or label of type ", idName tc ] [ idName c, "is not a constructor or label of type ", qualName tc ]
errModuleNotImported :: ModuleIdent -> Message errModuleNotImported :: ModuleIdent -> Message
errModuleNotImported m = posMessage m $ hsep $ map text errModuleNotImported m = posMessage m $ hsep $ map text
......
...@@ -49,7 +49,7 @@ module Checks.InterfaceCheck (interfaceCheck) where ...@@ -49,7 +49,7 @@ module Checks.InterfaceCheck (interfaceCheck) where
import Control.Monad (unless) import Control.Monad (unless)
import qualified Control.Monad.State as S import qualified Control.Monad.State as S
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (fromMaybe)
import Curry.Base.Ident import Curry.Base.Ident
import Curry.Base.Position import Curry.Base.Position
...@@ -156,7 +156,7 @@ checkConstrImport tc tvs (ConOpDecl p evs ty1 op ty2) = do ...@@ -156,7 +156,7 @@ checkConstrImport tc tvs (ConOpDecl p evs ty1 op ty2) = do
checkConstrImport tc tvs (RecordDecl p evs c fs) = do checkConstrImport tc tvs (RecordDecl p evs c fs) = do
m <- getModuleIdent m <- getModuleIdent
let qc = qualifyLike tc c let qc = qualifyLike tc c
(ls, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls] (ls, tys) = unzip [(l, ty) | FieldDecl _ labels ty <- fs, l <- labels]
checkConstr (DataConstructor c' _ ls' (ForAllExist uqvs eqvs ty')) = checkConstr (DataConstructor c' _ ls' (ForAllExist uqvs eqvs ty')) =
qc == c' && length evs == eqvs && length tvs == uqvs && ls == ls' && qc == c' && length evs == eqvs && length tvs == uqvs && ls == ls' &&
toQualTypes m tvs tys == arrowArgs ty' toQualTypes m tvs tys == arrowArgs ty'
......
...@@ -25,8 +25,6 @@ module Checks.InterfaceSyntaxCheck (intfSyntaxCheck) where ...@@ -25,8 +25,6 @@ module Checks.InterfaceSyntaxCheck (intfSyntaxCheck) where
import Control.Monad (liftM, liftM2) import Control.Monad (liftM, liftM2)
import qualified Control.Monad.State as S import qualified Control.Monad.State as S
import Data.List (nub, partition) import Data.List (nub, partition)
import Data.Maybe (catMaybes)
import qualified Data.Traversable as T (mapM)
import Base.Expr import Base.Expr
import Base.Messages (Message, posMessage, internalError) import Base.Messages (Message, posMessage, internalError)
...@@ -63,16 +61,13 @@ intfSyntaxCheck (Interface n is ds) = (Interface n is ds', reverse $ errors s') ...@@ -63,16 +61,13 @@ intfSyntaxCheck (Interface n is ds) = (Interface n is ds', reverse $ errors s')
-- The latter must not occur in type expressions in interfaces. -- The latter must not occur in type expressions in interfaces.
bindType :: IDecl -> TypeEnv -> TypeEnv bindType :: IDecl -> TypeEnv -> TypeEnv
bindType (IInfixDecl _ _ _ _) = id bindType (IInfixDecl _ _ _ _) = id
bindType (HidingDataDecl _ tc _) = qualBindTopEnv tc (Data tc []) bindType (HidingDataDecl _ tc _) = qualBindTopEnv tc (Data tc [])
bindType (IDataDecl _ tc _ cs) = qualBindTopEnv tc bindType (IDataDecl _ tc _ cs _) = qualBindTopEnv tc
(Data tc (map constr (catMaybes cs))) (Data tc (map constrId cs))
where constr (ConstrDecl _ _ c _) = c bindType (INewtypeDecl _ tc _ nc _) = qualBindTopEnv tc (Data tc [nconstrId nc])
constr (ConOpDecl _ _ _ op _) = op bindType (ITypeDecl _ tc _ _) = qualBindTopEnv tc (Alias tc)
bindType (INewtypeDecl _ tc _ nc) = qualBindTopEnv tc (Data tc [nconstr nc]) bindType (IFunctionDecl _ _ _ _) = id
where nconstr (NewConstrDecl _ _ c _) = c
bindType (ITypeDecl _ tc _ _) = qualBindTopEnv tc (Alias tc)
bindType (IFunctionDecl _ _ _ _) = id
-- The checks applied to the interface are similar to those performed -- The checks applied to the interface are similar to those performed
-- during syntax checking of type expressions. -- during syntax checking of type expressions.
...@@ -82,18 +77,30 @@ checkIDecl (IInfixDecl p fix pr op) = return (IInfixDecl p fix pr op) ...@@ -82,18 +77,30 @@ checkIDecl (IInfixDecl p fix pr op) = return (IInfixDecl p fix pr op)
checkIDecl (HidingDataDecl p tc tvs) = do checkIDecl (HidingDataDecl p tc tvs) = do
checkTypeLhs tvs checkTypeLhs tvs
return (HidingDataDecl p tc tvs) return (HidingDataDecl p tc tvs)
checkIDecl (IDataDecl p tc tvs cs) = do checkIDecl (IDataDecl p tc tvs cs hs) = do
checkTypeLhs tvs checkTypeLhs tvs
liftM (IDataDecl p tc tvs) (mapM (T.mapM (checkConstrDecl tvs)) cs) checkHidden tc (cons ++ labels) hs
checkIDecl (INewtypeDecl p tc tvs nc) = do cs' <- mapM (checkConstrDecl tvs) cs
return $ IDataDecl p tc tvs cs' hs
where cons = map constrId cs
labels = nub $ concatMap recordLabels cs
checkIDecl (INewtypeDecl p tc tvs nc hs) = do
checkTypeLhs tvs checkTypeLhs tvs
liftM (INewtypeDecl p tc tvs) (checkNewConstrDecl tvs nc) checkHidden tc (con : labels) hs
nc' <- checkNewConstrDecl tvs nc
return $ INewtypeDecl p tc tvs nc' hs
where con = nconstrId nc
labels = nrecordLabels nc
checkIDecl (ITypeDecl p tc tvs ty) = do checkIDecl (ITypeDecl p tc tvs ty) = do
checkTypeLhs tvs checkTypeLhs tvs
liftM (ITypeDecl p tc tvs) (checkClosedType tvs ty) liftM (ITypeDecl p tc tvs) (checkClosedType tvs ty)
checkIDecl (IFunctionDecl p f n ty) = checkIDecl (IFunctionDecl p f n ty) =
liftM (IFunctionDecl p f n) (checkType ty) liftM (IFunctionDecl p f n) (checkType ty)
checkHidden :: QualIdent -> [Ident] -> [Ident] -> ISC ()
checkHidden tc csls hs =
mapM_ (report . errNoElement tc) $ nub $ filter (`notElem` csls) hs
checkTypeLhs :: [Ident] -> ISC () checkTypeLhs :: [Ident] -> ISC ()
checkTypeLhs tvs = do checkTypeLhs tvs = do
tyEnv <- getTypeEnv tyEnv <- getTypeEnv
...@@ -120,7 +127,7 @@ checkConstrDecl tvs (RecordDecl p evs c fs) = do ...@@ -120,7 +127,7 @@ checkConstrDecl tvs (RecordDecl p evs c fs) = do
checkFieldDecl :: [Ident] -> FieldDecl -> ISC FieldDecl checkFieldDecl :: [Ident] -> FieldDecl -> ISC FieldDecl
checkFieldDecl tvs (FieldDecl p ls ty) = checkFieldDecl tvs (FieldDecl p ls ty) =
liftM (FieldDecl p ls ty) (checkClosedType tvs ty) liftM (FieldDecl p ls) (checkClosedType tvs ty)
checkNewConstrDecl :: [Ident] -> NewConstrDecl -> ISC NewConstrDecl checkNewConstrDecl :: [Ident] -> NewConstrDecl -> ISC NewConstrDecl
checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do
...@@ -187,3 +194,9 @@ errUnboundVariable tv = posMessage tv $ ...@@ -187,3 +194,9 @@ errUnboundVariable tv = posMessage tv $
errBadTypeSynonym :: QualIdent -> Message errBadTypeSynonym :: QualIdent -> Message
errBadTypeSynonym tc = posMessage tc $ text "Synonym type" errBadTypeSynonym tc = posMessage tc $ text "Synonym type"
<+> text (qualName tc) <+> text "in interface" <+> text (qualName tc) <+> text "in interface"
errNoElement :: QualIdent -> Ident -> Message
errNoElement tc x = posMessage tc $ hsep $ map text
[ "Hidden constructor or label ", escName x
, " is not defined for type ", qualName tc
]
\ No newline at end of file
...@@ -54,7 +54,7 @@ import Env.TypeConstructor (TCEnv, tcArity) ...@@ -54,7 +54,7 @@ import Env.TypeConstructor (TCEnv, tcArity)
kindCheck :: TCEnv -> Module -> (Module, [Message]) kindCheck :: TCEnv -> Module -> (Module, [Message])
kindCheck tcEnv mdl@(Module _ m _ _ ds) = kindCheck tcEnv mdl@(Module _ m _ _ ds) =
case findMultiples $ map typeConstr tds of case findMultiples $ map typeConstr tds of
[] -> runKCM (mapM checkModule mdl) state [] -> runKCM (checkModule mdl) state
tss -> (mdl, map errMultipleDeclaration tss) tss -> (mdl, map errMultipleDeclaration tss)
where tds = filter isTypeDecl ds