Commit 78887d02 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Further modifications to support Haskell's record syntax

parent cdd81066
......@@ -18,8 +18,8 @@
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
-- * Representation of Quantification
......@@ -41,7 +41,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
......@@ -81,6 +80,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
......
......@@ -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
......@@ -11,7 +11,7 @@
-}
module Base.Typing (Typeable (..)) where
module Base.Typing (Typeable (..), argumentTypes) where
import Control.Monad
import qualified Control.Monad.State as S (State, evalState, gets, modify)
......@@ -26,7 +26,8 @@ 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
, conType)
-- During the transformation of Curry source code into the intermediate
-- language, the compiler has to recompute the types of expressions. This
......@@ -176,6 +177,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 +200,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 +211,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 +265,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 +273,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 <- instType (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
......@@ -402,43 +354,27 @@ 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 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 type of constructors, pattern variables, and variables.
......@@ -446,8 +382,8 @@ 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
......
......@@ -27,6 +27,7 @@ module Env.Value
, bindGlobalInfo, bindFun, qualBindFun, rebindFun, unbindFun
, lookupValue, qualLookupValue
, initDCEnv, ppTypes
, conType
) where
import Curry.Base.Ident
......@@ -154,3 +155,10 @@ ppTypes mid valueEnv = ppTypes' mid $ localBindings valueEnv
mkDecl _ = internalError "Env.Value.ppTypes: no value"
isValue (Value _ _ _) = True
isValue _ = False
conType :: QualIdent -> ValueEnv -> ([Ident], ExistTypeScheme)
conType c tyEnv = case qualLookupTopEnv c tyEnv of
[DataConstructor _ _ ls ty] -> (ls, ty)
[NewtypeConstructor _ l ty] -> ([l], ty)
_ -> internalError $ "Env.Value.conType: " ++ show c
\ No newline at end of file
......@@ -4,6 +4,7 @@
Copyright : (c) 2000 - 2004, Wolfgang Lux
2005 , Martin Engelke
2011 - 2013, Björn Peemöller
2015 , Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -78,23 +79,31 @@ iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
IInfixDecl NoPos fix pr (qualUnqualify m op) : ds
_ -> internalError "Exports.infixDecl"
-- Data types and renaming types whose constructors and field labels are
-- not exported are exported as abstract types, i.e., their constructors
-- do not appear in the interface. If only some constructors or field
-- labels of a type are not exported all constructors appear in the
-- interface, but a pragma marks the constructors and field labels which
-- are not exported as hidden to prevent their use in user code.
typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]
typeDecl _ _ (Export _) ds = ds
typeDecl m tcEnv (ExportTypeWith tc cs) ds = case qualLookupTC tc tcEnv of
[DataType tc' n cs'] ->
iTypeDecl IDataDecl m tc' n
(constrDecls m (drop n identSupply) cs cs') : ds
[RenamingType tc' n (DataConstr c n' [ty])]
| c `elem` cs ->
iTypeDecl INewtypeDecl m tc' n (NewConstrDecl NoPos tvs c ty') : ds
| otherwise -> iTypeDecl IDataDecl m tc' n [] : ds
where tvs = take n' (drop n identSupply)
ty' = fromQualType m ty
[AliasType tc' n ty] -> case ty of
TypeRecord fs ->
let ty' = TypeRecord (filter (\ (l,_) -> elem l cs) fs)
in iTypeDecl ITypeDecl m tc' n (fromQualType m ty') : ds
_ -> iTypeDecl ITypeDecl m tc' n (fromQualType m ty) : ds
typeDecl m tcEnv (ExportTypeWith tc xs) ds = case qualLookupTC tc tcEnv of
[DataType tc' n cs]
| null xs -> iTypeDecl IDataDecl m tc' n [] [] : ds
| otherwise -> iTypeDecl IDataDecl m tc' n cs' hs : ds
where hs = filter (`notElem` xs) (csIds ++ ls)
cs' = map constrDecl m (drop n identSupply) cs
ls = nub (concatMap recordLabels cs')
csIds = map constrIdent cs
[RenamingType tc' n c]
| null xs -> iTypeDecl IDataDecl tc' n [] [] : ds
| otherwise -> iTypeDecl INewtypeDecl tc' n nc hs : ds
where hs = filter (`notElem` xs) (cId : ls)
nc = newConstrDecl m (drop n identSupply) c
ls = nrecordLabels nc
cId = constrIdent c
[AliasType tc' n ty] -> iTypeDecl ITypeDecl m tc' n (fromQualType m ty) : ds
_ -> internalError "Exports.typeDecl"
typeDecl _ _ _ _ = internalError "Exports.typeDecl: no pattern match"
......@@ -102,19 +111,27 @@ iTypeDecl :: (Position -> QualIdent -> [Ident] -> a -> IDecl)
-> ModuleIdent -> QualIdent -> Int -> a -> IDecl
iTypeDecl f m tc n = f NoPos (qualUnqualify m tc) (take n identSupply)
constrDecls :: ModuleIdent -> [Ident] -> [Ident] -> [Maybe DataConstr]
-> [Maybe ConstrDecl]
constrDecls m tvs cs = clean . map (>>= constrDecl m tvs)
where clean = reverse . dropWhile isNothing . reverse
constrDecl m' tvs' (DataConstr c n tys)
| c `elem` cs =
Just (iConstrDecl (take n tvs') c (map (fromQualType m') tys))
| otherwise = Nothing
iConstrDecl :: [Ident] -> Ident -> [TypeExpr] -> ConstrDecl
iConstrDecl tvs op [ty1,ty2]
| isInfixOp op = ConOpDecl NoPos tvs ty1 op ty2
iConstrDecl tvs c tys = ConstrDecl NoPos tvs c tys
constrDecl :: ModuleIdent -> [Ident] -> DataConstr -> ConstrDecl
constrDecl m tvs (DataConstr c n [ty1,ty2])
| isInfixOp c = ConOpDecl NoPos evs (fromQualType m ty1) c (fromQualType m ty2)
where evs = take n tvs
constrDecl m tvs (DataConstr c n tys) = ConstrDecl NoPos evs c tys'
where evs = take n tvs
tys' = map (fromQualType m) tys
constrDecl m tvs (RecordConstr c n ls tys) = RecordDecl NoPos evs c fs
where
evs = take n tvs
tys' = map (fromQualType m) tys
fs = zipWith (FieldDecl NoPos . return) ls tys'
newConstrDecl :: ModuleIdent -> [Ident] -> DataConstr -> NewConstrDecl
newConstrDecl m tvs (DataConstr c n [ty]) = NewConstrDecl NoPos evs c ty'
where evs = take n tvs
ty' = fromQualType m ty
newConstrDecl m tvs (RecordConstr c n [l] [ty])
= NewRecordDecl NoPos evs c (l,ty')
where evs = take n tvs
ty' = fromQualType m ty
funDecl :: ModuleIdent -> ValueEnv -> Export -> [IDecl] -> [IDecl]
funDecl m tyEnv (Export f) ds = case qualLookupValue f tyEnv of
......@@ -147,20 +164,25 @@ usedModules ds = nub' (catMaybes (map qidModule (foldr identsDecl [] ds)))
where nub' = Set.toList . Set.fromList
identsDecl :: IDecl -> [QualIdent] -> [QualIdent]
identsDecl (IDataDecl _ tc _ cs) xs =
tc : foldr identsConstrDecl xs (catMaybes cs)
identsDecl (INewtypeDecl _ tc _ nc) xs = tc : identsNewConstrDecl nc xs
identsDecl (ITypeDecl _ tc _ ty) xs = tc : identsType ty xs
identsDecl (IFunctionDecl _ f _ ty) xs = f : identsType ty xs
identsDecl (IDataDecl _ tc _ cs _) xs =
tc : foldr identsConstrDecl xs cs
identsDecl (INewtypeDecl _ tc _ nc _) xs = tc : identsNewConstrDecl nc xs
identsDecl (ITypeDecl _ tc _ ty) xs = tc : identsType ty xs
identsDecl (IFunctionDecl _ f _ ty) xs = f : identsType ty xs
identsDecl _ _ = internalError "Exports.identsDecl: no pattern match"
identsConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
identsConstrDecl (ConstrDecl _ _ _ tys) xs = foldr identsType xs tys
identsConstrDecl (ConOpDecl _ _ ty1 _ ty2) xs =
identsType ty1 (identsType ty2 xs)
identsConstrDecl (RecordDecl _ _ _ fs) xs = foldr identsFieldDecl xs fs
identsFieldDecl :: FieldDecl -> [QualIdent] -> [QualIdent]
identsFieldDecl (FieldDecl _ _ ty) xs = identsType ty xs
identsNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
identsNewConstrDecl (NewConstrDecl _ _ _ ty) xs = identsType ty xs
identsNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) xs = identsType ty xs
identsType :: TypeExpr -> [QualIdent] -> [QualIdent]
identsType (ConstructorType tc tys) xs = tc : foldr identsType xs tys
......@@ -168,7 +190,6 @@ identsType (VariableType _) xs = xs
identsType (TupleType tys) xs = foldr identsType xs tys
identsType (ListType ty) xs = identsType ty xs
identsType (ArrowType ty1 ty2) xs = identsType ty1 (identsType ty2 xs)
identsType (RecordType fs) xs = foldr identsType xs (map snd fs)
-- After the interface declarations have been computed, the compiler
-- eventually must add hidden (data) type declarations to the interface
......@@ -180,8 +201,6 @@ hiddenTypeDecl :: ModuleIdent -> TCEnv -> QualIdent -> IDecl
hiddenTypeDecl m tcEnv tc = case qualLookupTC (qualQualify m tc) tcEnv of
[DataType _ n _] -> hidingDataDecl tc n
[RenamingType _ n _] -> hidingDataDecl tc n
-- jrt 2014-10-16: Added for support of record types
[AliasType _ n _] -> hidingDataDecl tc n
_ -> internalError "Exports.hiddenTypeDecl"
where hidingDataDecl tc1 n = HidingDataDecl NoPos tc1 $ take n identSupply
......@@ -195,12 +214,12 @@ usedTypes :: [IDecl] -> [QualIdent]
usedTypes ds = foldr usedTypesDecl [] ds
usedTypesDecl :: IDecl -> [QualIdent] -> [QualIdent]
usedTypesDecl (IDataDecl _ _ _ cs) tcs =
foldr usedTypesConstrDecl tcs (catMaybes cs)
usedTypesDecl (INewtypeDecl _ _ _ nc) tcs = usedTypesNewConstrDecl nc tcs
usedTypesDecl (ITypeDecl _ _ _ ty) tcs = usedTypesType ty tcs
usedTypesDecl (IFunctionDecl _ _ _ ty) tcs = usedTypesType ty tcs
usedTypesDecl _ _ = internalError
usedTypesDecl (IDataDecl _ _ _ cs _) tcs =
foldr usedTypesConstrDecl tcs cs
usedTypesDecl (INewtypeDecl _ _ _ nc _) tcs = usedTypesNewConstrDecl nc tcs
usedTypesDecl (ITypeDecl _ _ _ ty ) tcs = usedTypesType ty tcs
usedTypesDecl (IFunctionDecl _ _ _ ty ) tcs = usedTypesType ty tcs
usedTypesDecl _ _ = internalError
"Exports.usedTypesDecl: no pattern match" -- TODO
usedTypesConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
......@@ -208,9 +227,15 @@ usedTypesConstrDecl (ConstrDecl _ _ _ tys) tcs =
foldr usedTypesType tcs tys
usedTypesConstrDecl (ConOpDecl _ _ ty1 _ ty2) tcs =
usedTypesType ty1 (usedTypesType ty2 tcs)
usedTypesConstrDecl (RecordDecl _ _ _ fs) tcs =
foldr usedTypesFieldDecl tcs fs
usedTypesFieldDecl :: FieldDecl -> [QualIdent] -> [QualIdent]
usedTypesFieldDecl (FieldDecl _ _ ty) tcs = usedTypesType tcs ty
usedTypesNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
usedTypesNewConstrDecl (NewConstrDecl _ _ _ ty) tcs = usedTypesType ty tcs
usedTypesNewConstrDecl (NewConstrDecl _ _ _ ty) tcs = usedTypesType ty tcs
usedTypesNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) tcs = usedTypesType ty tcs
usedTypesType :: TypeExpr -> [QualIdent] -> [QualIdent]
usedTypesType (ConstructorType tc tys) tcs = tc : foldr usedTypesType tcs tys
......@@ -219,14 +244,12 @@ usedTypesType (TupleType tys) tcs = foldr usedTypesType tcs tys
usedTypesType (ListType ty) tcs = usedTypesType ty tcs
usedTypesType (ArrowType ty1 ty2) tcs =
usedTypesType ty1 (usedTypesType ty2 tcs)
usedTypesType (RecordType fs) tcs = foldr usedTypesType
tcs (map snd fs)
definedTypes :: [IDecl] -> [QualIdent]
definedTypes ds = foldr definedType [] ds
where
definedType :: IDecl -> [QualIdent] -> [QualIdent]
definedType (IDataDecl _ tc _ _) tcs = tc : tcs
definedType (INewtypeDecl _ tc _ _) tcs = tc : tcs
definedType (ITypeDecl _ tc _ _) tcs = tc : tcs
definedType _ tcs = tcs
definedType (IDataDecl _ tc _ _ _) tcs = tc : tcs
definedType (INewtypeDecl _ tc _ _ _) tcs = tc : tcs
definedType (ITypeDecl _ tc _ _ ) tcs = tc : tcs
definedType _ tcs = tcs
......@@ -2,6 +2,7 @@
Module : $Header$
Description : Summarized information of a module
Copyright : (c) 2005, Martin Engelke (men@informatik.uni-kiel.de)
2015, Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -76,10 +77,8 @@ genTypeSyns tcEnv mident decls
= concatMap (genTypeSynDecl mident tcEnv) $ filter isTypeSyn decls
isTypeSyn :: Decl -> Bool
isTypeSyn (TypeDecl _ _ _ texpr) = case texpr of
RecordType _ -> False
_ -> True
isTypeSyn _ = False
isTypeSyn (TypeDecl _ _ _ _) = True
isTypeSyn _ = False
--
genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> [IDecl]
......@@ -103,8 +102,6 @@ modifyTypeExpr tcEnv (TupleType tys)
(map (modifyTypeExpr tcEnv) tys)
modifyTypeExpr tcEnv (ListType ty)
= ConstructorType (qualify listId) [modifyTypeExpr tcEnv ty]
modifyTypeExpr tcEnv (RecordType fields)
= RecordType (map (\ (lbls, lty) -> (lbls, modifyTypeExpr tcEnv lty)) fields)
--
genTypeSynDeref :: [(Int, TypeExpr)] -> Type -> TypeExpr
......@@ -115,9 +112,6 @@ genTypeSynDeref its (TypeConstructor qid tys)
= ConstructorType qid $ map (genTypeSynDeref its) tys
genTypeSynDeref its (TypeArrow ty1 ty2)
= ArrowType (genTypeSynDeref its ty1) (genTypeSynDeref its ty2)
genTypeSynDeref its (TypeRecord fields)
= RecordType
(map (\ (lab, texpr) -> ([lab], genTypeSynDeref its texpr)) fields)
genTypeSynDeref _ (TypeConstrained _ _) = internalError
"ModuleSummary.genTypeSynDeref: illegal constrained type occured"
genTypeSynDeref _ (TypeSkolem _) = internalError
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment