Skip to content

GitLab

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

Merge branch 'records'

parents efc6fb5a e4a420e9
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1031 additions and 1113 deletions
src/Base/CurryTypes.hs
View file @ 99e0b121
......@@ -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
......
src/Base/Expr.hs
View file @ 99e0b121
......@@ -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))
......
src/Base/TopEnv.hs
View file @ 99e0b121
......@@ -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]
src/Base/TypeSubst.hs
View file @ 99e0b121
......@@ -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
......
src/Base/Types.hs
View file @ 99e0b121
......@@ -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
......
src/Base/Typing.hs
View file @ 99e0b121
......@@ -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
src/Checks.hs
View file @ 99e0b121
......@@ -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.
--
......
src/Checks/ExportCheck.hs
View file @ 99e0b121
......@@ -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 })