Commit 99e0b121 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Merge branch 'records'

parents efc6fb5a e4a420e9
......@@ -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
......@@ -93,6 +94,8 @@ instance QualExpr Expression where
qfv _ (Constructor _) = []
qfv m (Paren 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 (List _ es) = qfv m es
qfv m (ListCompr _ e qs) = foldr (qfvStmt m) (qfv m e) qs
......@@ -110,9 +113,6 @@ 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
qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident]
qfvStmt m st fvs = qfv m st ++ filterBv st fvs
......@@ -147,13 +147,13 @@ instance QuantExpr Pattern where
bv (ConstructorPattern _ ts) = bv ts
bv (InfixPattern t1 _ t2) = bv t1 ++ bv t2
bv (ParenPattern t) = bv t
bv (RecordPattern _ fs) = bv fs
bv (TuplePattern _ ts) = bv ts
bv (ListPattern _ ts) = bv ts
bv (AsPattern v t) = v : bv t
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
instance QualExpr Pattern where
qfv _ (LiteralPattern _) = []
......@@ -162,6 +162,7 @@ instance QualExpr Pattern where
qfv m (ConstructorPattern _ ts) = qfv m ts
qfv m (InfixPattern t1 _ t2) = qfv m [t1, t2]
qfv m (ParenPattern t) = qfv m t
qfv m (RecordPattern _ fs) = qfv m fs
qfv m (TuplePattern _ ts) = qfv m ts
qfv m (ListPattern _ ts) = qfv m ts
qfv m (AsPattern _ ts) = qfv m ts
......@@ -170,7 +171,6 @@ 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
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 -> [a]
allEntities (TopEnv env) = [ y | (_, ys) <- Map.toList env, (_, y) <- ys]
......@@ -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) =
......@@ -56,10 +54,10 @@ instance SubstType ExistTypeScheme where
ForAllExist n n' (subst (foldr unbindSubst sigma [0..n+n'-1]) ty)
instance SubstType ValueInfo where
subst _ dc@(DataConstructor _ _ _) = dc
subst _ nc@(NewtypeConstructor _ _) = nc
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 _ dc@(DataConstructor _ _ _ _) = dc
subst _ nc@(NewtypeConstructor _ _ _) = nc
subst theta (Value v a ty) = Value v a (subst theta ty)
subst theta (Label l r ty) = Label l r (subst theta ty)
instance SubstType a => SubstType (TopEnv a) where
subst = fmap . subst
......@@ -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
......@@ -17,10 +18,11 @@
module Base.Types
( -- * Representation of Types
Type (..), isArrowType, arrowArity, arrowArgs, arrowBase, typeVars
, typeConstrs, typeSkolems, equTypes, qualifyType, unqualifyType
Type (..), isArrowType, arrowArity, arrowArgs, arrowBase, arrowUnapply
, typeVars, typeConstrs, typeSkolems, equTypes, qualifyType, unqualifyType
-- * Representation of Data Constructors
, DataConstr (..), constrIdent, tupleData
, DataConstr (..), constrIdent, constrTypes, recLabels, recLabelTypes
, tupleData
-- * Representation of Quantification
, TypeScheme (..), ExistTypeScheme (..), monoType, polyType
-- * Predefined types
......@@ -40,7 +42,6 @@ import Curry.Base.Ident
-- from the constraint list.
-- The case 'TypeSkolem' is used for handling skolem types, which
-- result from the use of existentially quantified data constructors.
-- Finally, 'TypeRecord' is used for records.
-- Type variables are represented with deBruijn style indices. Universally
-- quantified type variables are assigned indices in the order of their
......@@ -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
......@@ -81,6 +81,11 @@ arrowBase :: Type -> Type
arrowBase (TypeArrow _ ty) = arrowBase ty
arrowBase ty = ty
arrowUnapply :: Type -> ([Type], Type)
arrowUnapply (TypeArrow ty1 ty2) = (ty1 : tys, ty)
where (tys, ty) = arrowUnapply ty2
arrowUnapply ty = ([], ty)
-- The functions 'typeVars', 'typeConstrs', 'typeSkolems' return a list of all
-- type variables, type constructors, or skolems occurring in a type t,
-- respectively. Note that 'TypeConstrained' variables are not included in the
......@@ -93,7 +98,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 +106,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 +114,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 +136,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 +143,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 +168,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 +178,28 @@ 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.
data DataConstr = DataConstr Ident Int [Type]
-- 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
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
-- quantified type schemes (forall alpha . tau(alpha)) and universally
......
......@@ -2,7 +2,7 @@
Module : $Header$
Description : Type computation of Curry expressions
Copyright : (c) 2003 - 2006 Wolfgang Lux
2014 Jan Tikovsky
2014 - 2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -25,8 +25,7 @@ import Base.Types
import Base.TypeSubst
import Base.Utils (foldr2)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
import Env.Value ( ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
-- During the transformation of Curry source code into the intermediate
-- language, the compiler has to recompute the types of expressions. This
......@@ -91,16 +90,12 @@ import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
data TcState = TcState
{ valueEnv :: ValueEnv
, tyConsEnv :: TCEnv
, typeSubst :: TypeSubst
, nextId :: Int
}
type TCM = S.State TcState
getTyConsEnv :: TCM TCEnv
getTyConsEnv = S.gets tyConsEnv
getValueEnv :: TCM ValueEnv
getValueEnv = S.gets valueEnv
......@@ -116,12 +111,12 @@ getNextId = do
S.modify $ \ s -> s { nextId = succ nid }
return nid
run :: TCM a -> ValueEnv -> TCEnv -> a
run m tyEnv tcEnv = S.evalState m initState
where initState = TcState tyEnv tcEnv idSubst 0
run :: TCM a -> ValueEnv -> a
run m tyEnv = S.evalState m initState
where initState = TcState tyEnv idSubst 0
class Typeable a where
typeOf :: ValueEnv -> TCEnv -> a -> Type
typeOf :: ValueEnv -> a -> Type
instance Typeable Ident where
typeOf = computeType identType
......@@ -135,8 +130,8 @@ instance Typeable Expression where
instance Typeable Rhs where
typeOf = computeType rhsType
computeType :: (a -> TCM Type) -> ValueEnv -> TCEnv -> a -> Type
computeType f tyEnv tcEnv x = normalize (run doComputeType tyEnv tcEnv)
computeType :: (a -> TCM Type) -> ValueEnv -> a -> Type
computeType f tyEnv x = normalize (run doComputeType tyEnv)
where
doComputeType = do
ty <- f x
......@@ -176,6 +171,11 @@ argType (ConstructorPattern c ts) = do
argType (InfixPattern t1 op t2) =
argType (ConstructorPattern op [t1,t2])
argType (ParenPattern t) = argType t
argType (RecordPattern c fs) = do
tyEnv <- getValueEnv
ty <- liftM arrowBase $ instUnivExist $ constrType c tyEnv
mapM_ (fieldType argType ty) fs
return ty
argType (TuplePattern _ ts)
| null ts = return unitType
| otherwise = liftM tupleType $ mapM argType ts
......@@ -194,26 +194,6 @@ argType (FunctionPattern f ts) = do
where flatten (TypeArrow ty1 ty2) = ty1 : flatten ty2
flatten ty = [ty]
argType (InfixFuncPattern t1 op t2) = argType (FunctionPattern op [t1,t2])
argType (RecordPattern fs _) = do
recInfo <- getFieldIdent fs >>= getRecordInfo
case recInfo of
[AliasType qi n rty@(TypeRecord _)] -> do
(TypeRecord fts', tys) <- instType' n rty
fts <- mapM fieldPattType fs
theta <- getTypeSubst
let theta' = foldr (unifyTypedLabels fts') theta fts
modifyTypeSubst (const theta')
return (subst theta' $ TypeConstructor qi tys)
info -> internalError $ "Base.Typing.argType: Expected record type but got "
++ show info
fieldPattType :: Field Pattern -> TCM (Ident,Type)
fieldPattType (Field _ l t) = do
tyEnv <- getValueEnv
lty <- instUniv (labelType l tyEnv)
ty <- argType t
unify lty ty
return (l,lty)
exprType :: Expression -> TCM Type
exprType (Literal l) = litType l
......@@ -225,6 +205,15 @@ exprType (Constructor c) = do
instUnivExist (constrType c tyEnv)
exprType (Typed e _) = exprType e
exprType (Paren e) = exprType e
exprType (Record c fs) = do
tyEnv <- getValueEnv
ty <- liftM arrowBase $ instUnivExist $ constrType c tyEnv
mapM_ (fieldType exprType ty) fs
return ty
exprType (RecordUpdate e fs) = do
ty <- exprType e
mapM_ (fieldType exprType ty) fs
return ty
exprType (Tuple _ es)
| null es = return unitType
| otherwise = liftM tupleType $ mapM exprType es
......@@ -270,50 +259,6 @@ exprType (Case _ _ _ alts) = freshTypeVar >>= flip altType alts
where altType ty [] = return ty
altType ty (Alt _ _ rhs:alts1) =
rhsType rhs >>= unify ty >> altType ty alts1
exprType (RecordConstr fs) = do
recInfo <- getFieldIdent fs >>= getRecordInfo
case recInfo of
[AliasType qi n rty@(TypeRecord _)] -> do
(TypeRecord fts', tys) <- instType' n rty
fts <- mapM fieldExprType fs
theta <- getTypeSubst
let theta' = foldr (unifyTypedLabels fts') theta fts
modifyTypeSubst (const theta')
return (subst theta' $ TypeConstructor qi tys)
info -> internalError $
"Base.Typing.exprType: Expected record type but got " ++ show info
exprType (RecordSelection e l) = do
recInfo <- getRecordInfo l
case recInfo of
[AliasType qi n rty@(TypeRecord _)] -> do
(TypeRecord fts, tys) <- instType' n rty
ety <- exprType e
let rtc = TypeConstructor qi tys
case lookup l fts of
Just lty -> do
unify ety rtc
theta <- getTypeSubst
return (subst theta lty)
Nothing -> internalError "Base.Typing.exprType: Field not found."
info -> internalError $
"Base.Typing.exprType: Expected record type but got " ++ show info
exprType (RecordUpdate fs e) = do
recInfo <- getFieldIdent fs >>= getRecordInfo
case recInfo of
[AliasType qi n rty@(TypeRecord _)] -> do
(TypeRecord fts', tys) <- instType' n rty
-- Type check field updates
fts <- mapM fieldExprType fs
modifyTypeSubst (\s -> foldr (unifyTypedLabels fts') s fts)
-- Type check record expression to be updated
ety <- exprType e
let rtc = TypeConstructor qi tys
unify ety rtc
-- Return inferred type
theta <- getTypeSubst
return (subst theta rtc)
info -> internalError $
"Base.Typing.exprType: Expected record type but got " ++ show info
rhsType :: Rhs -> TCM Type
rhsType (SimpleRhs _ e _) = exprType e
......@@ -322,13 +267,14 @@ rhsType (GuardedRhs es _) = freshTypeVar >>= flip condExprType es
condExprType ty (CondExpr _ _ e:es1) =
exprType e >>= unify ty >> condExprType ty es1
fieldExprType :: Field Expression -> TCM (Ident,Type)
fieldExprType (Field _ l e) = do
fieldType :: (a -> TCM Type) -> Type -> Field a -> TCM Type
fieldType tcheck ty (Field _ l x) = do
tyEnv <- getValueEnv
lty <- instUniv (labelType l tyEnv)
ty <- exprType e
unify lty ty
return (l,lty)
TypeArrow ty1 ty2 <- instUniv (labelType l tyEnv)
unify ty ty1
lty <- tcheck x
unify ty2 lty
return lty
-- In order to avoid name conflicts with non-generalized type variables
-- in a type we instantiate quantified type variables using non-negative
......@@ -342,11 +288,6 @@ instType n ty = do
tys <- replicateM n freshTypeVar
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 (ForAll n ty) = instType n ty
......@@ -402,43 +343,9 @@ unifyTypes (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) theta =
unifyTypes ty11 ty21 (unifyTypes ty12 ty22 theta)
unifyTypes (TypeSkolem k1) (TypeSkolem k2) theta
| k1 == k2 = theta
unifyTypes (TypeRecord fs1) (TypeRecord fs2) theta
| length fs1 == length fs2 = foldr (unifyTypedLabels fs1) theta fs2
unifyTypes ty1 ty2 _ = internalError $
"Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")"
-- jrt 2014-10-20: Deactivated because the parser can not parse
-- record extensions, thus, these cases should never occur. If they do,
-- there must be an error somewhere ...
-- unifyTypes tr1@(TypeRecord fs1 Nothing) (TypeRecord fs2 (Just a2)) theta =
-- unifyTypes (TypeVariable a2)
-- tr1
-- (foldr (unifyTypedLabels fs1) theta fs2)
-- unifyTypes tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) theta =
-- unifyTypes tr2 tr1 theta
-- unifyTypes (TypeRecord fs1 (Just a1)) (TypeRecord fs2 (Just a2)) theta =
-- unifyTypes (TypeVariable a1)
-- (TypeVariable a2)
-- (foldr (unifyTypedLabels fs1) theta fs2)
unifyTypedLabels :: [(Ident,Type)] -> (Ident,Type) -> TypeSubst -> TypeSubst
unifyTypedLabels fs1 (l,ty) theta =
maybe theta (\ty1 -> unifyTypes ty1 ty theta) (lookup l fs1)
getFieldIdent :: [Field a] -> TCM Ident
getFieldIdent [] = internalError "Base.Typing.getFieldIdent: empty field"
getFieldIdent (Field _ i _ : _) = return i
-- Lookup record type for given field identifier
getRecordInfo :: Ident -> TCM [TypeInfo]
getRecordInfo i = do
tyEnv <- getValueEnv
tcEnv <- getTyConsEnv
case lookupValue i tyEnv of
[Label _ r _] -> return (qualLookupTC r tcEnv)
_ -> internalError $
"Base.Typing.getRecordInfo: No record found for identifier " ++ show i
-- The functions 'constrType', 'varType', and 'funType' are used for computing
-- the type of constructors, pattern variables, and variables.
......@@ -446,21 +353,23 @@ getRecordInfo i = do
constrType :: QualIdent -> ValueEnv -> ExistTypeScheme
constrType c tyEnv = case qualLookupValue c tyEnv of
[DataConstructor _ _ sigma] -> sigma
[NewtypeConstructor _ sigma] -> sigma
[DataConstructor _ _ _ sigma] -> sigma
[NewtypeConstructor _ _ sigma] -> sigma
_ -> internalError $ "Base.Typing.constrType: " ++ show c
varType :: Ident -> ValueEnv -> TypeScheme
varType v tyEnv = case lookupValue v tyEnv of
[Value _ _ sigma] -> sigma
[Label _ _ sigma] -> sigma
_ -> internalError $ "Base.Typing.varType: " ++ show v
funType :: QualIdent -> ValueEnv -> TypeScheme
funType f tyEnv = case qualLookupValue f tyEnv of
[Value _ _ sigma] -> sigma
[Label _ _ sigma] -> sigma
_ -> internalError $ "Base.Typing.funType: " ++ show f
labelType :: Ident -> ValueEnv -> TypeScheme
labelType l tyEnv = case lookupValue l tyEnv of
labelType :: QualIdent -> ValueEnv -> TypeScheme
labelType l tyEnv = case qualLookupValue l tyEnv of
[Label _ _ sigma] -> sigma
_ -> internalError $ "Base.Typing.labelType: " ++ show l
......@@ -57,8 +57,7 @@ syntaxCheck :: Monad m => Check m Module
syntaxCheck opts (env, mdl)
| null msgs = ok (env { extensions = exts }, mdl')
| otherwise = failMessages msgs
where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env)
(tyConsEnv env) mdl
where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env) mdl
-- |Check the precedences of infix operators.
--
......
......@@ -13,11 +13,12 @@
-}
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 (Map, elems, empty, insertWith
, toList)
import qualified Data.Map as Map (Map, elems, empty, insert
, insertWith, lookup, toList)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set (Set, empty, fromList, insert
, member, toList)
......@@ -28,14 +29,14 @@ import Curry.Base.Pretty
import Curry.Syntax
import Base.Messages (Message, internalError, posMessage)
import Base.TopEnv (origName, localBindings, moduleImports)
import Base.Types (DataConstr (..), Type (..))
import Base.TopEnv (allEntities, origName, localBindings, moduleImports)
import Base.Types ( DataConstr (..), ExistTypeScheme (..), Type (..)
, TypeScheme (..), arrowBase, constrIdent, recLabels)
import Base.Utils (findMultiples)
import Env.ModuleAlias (AliasEnv)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), lookupValue
, qualLookupValue)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
-- ---------------------------------------------------------------------------
-- Check and expansion of the export statement
......@@ -47,7 +48,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
......@@ -87,9 +89,9 @@ report :: Message -> ECM ()
report err = S.modify (\ s -> s { errors = err : errors s })