From efb6ab8da6510bb52ca4344dcf25c1eecd08a8f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Peem=C3=B6ller?= Date: Mon, 21 Dec 2015 16:40:17 +0100 Subject: [PATCH] Consider parenthesized type expressions in Curry AST (by Katharina Rahf) --- CHANGELOG.md | 2 ++ src/Base/CurryTypes.hs | 3 ++- src/Base/Expr.hs | 1 + src/Checks/InterfaceSyntaxCheck.hs | 3 ++- src/Checks/KindCheck.hs | 2 ++ src/Checks/TypeCheck.hs | 3 +++ src/Checks/WarnCheck.hs | 4 ++-- src/Exports.hs | 2 ++ src/Generators/GenAbstractCurry.hs | 1 + src/Generators/GenFlatCurry.hs | 1 + src/Html/SyntaxColoring.hs | 1 + src/ModuleSummary.hs | 9 +++++---- src/Transformations/Qual.hs | 1 + 13 files changed, 25 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 74bda67d..364d0cbc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,8 @@ Change log for curry-frontend Under development ================= + * Consider parenthesized type expressions in the Curry AST (by Katharina Rahf) + Version 0.4.0 ============= diff --git a/src/Base/CurryTypes.hs b/src/Base/CurryTypes.hs index 0089001e..bc98eba7 100644 --- a/src/Base/CurryTypes.hs +++ b/src/Base/CurryTypes.hs @@ -68,6 +68,7 @@ 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.ParenType ty) = toType' tvs ty fromQualType :: ModuleIdent -> Type -> CS.TypeExpr fromQualType m = fromType . unqualifyType m @@ -93,4 +94,4 @@ ppType :: ModuleIdent -> Type -> Doc ppType m = ppTypeExpr 0 . fromQualType m ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc -ppTypeScheme m (ForAll _ ty) = ppType m ty \ No newline at end of file +ppTypeScheme m (ForAll _ ty) = ppType m ty diff --git a/src/Base/Expr.hs b/src/Base/Expr.hs index 683790cc..1c0c91e9 100644 --- a/src/Base/Expr.hs +++ b/src/Base/Expr.hs @@ -180,6 +180,7 @@ instance Expr TypeExpr where fv (TupleType tys) = fv tys fv (ListType ty) = fv ty fv (ArrowType ty1 ty2) = fv ty1 ++ fv ty2 + fv (ParenType ty) = fv ty filterBv :: QuantExpr e => e -> [Ident] -> [Ident] filterBv e = filter (`Set.notMember` Set.fromList (bv e)) diff --git a/src/Checks/InterfaceSyntaxCheck.hs b/src/Checks/InterfaceSyntaxCheck.hs index 17f25ce4..08993a7b 100644 --- a/src/Checks/InterfaceSyntaxCheck.hs +++ b/src/Checks/InterfaceSyntaxCheck.hs @@ -152,6 +152,7 @@ checkType (VariableType tv) = checkType (ConstructorType (qualify tv) []) checkType (TupleType tys) = liftM TupleType (mapM checkType tys) checkType (ListType ty) = liftM ListType (checkType ty) checkType (ArrowType ty1 ty2) = liftM2 ArrowType (checkType ty1) (checkType ty2) +checkType (ParenType ty) = liftM ParenType (checkType ty) checkTypeConstructor :: QualIdent -> [TypeExpr] -> ISC TypeExpr checkTypeConstructor tc tys = do @@ -199,4 +200,4 @@ 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 + ] diff --git a/src/Checks/KindCheck.hs b/src/Checks/KindCheck.hs index 736ba8f2..4afeba4c 100644 --- a/src/Checks/KindCheck.hs +++ b/src/Checks/KindCheck.hs @@ -269,6 +269,7 @@ checkType v@(VariableType tv) checkType (TupleType tys) = TupleType <$> mapM checkType tys checkType (ListType ty) = ListType <$> checkType ty checkType (ArrowType ty1 ty2) = ArrowType <$> checkType ty1 <*> checkType ty2 +checkType (ParenType ty) = ParenType <$> checkType ty checkClosed :: [Ident] -> TypeExpr -> KCM () checkClosed tvs (ConstructorType _ tys) = mapM_ (checkClosed tvs) tys @@ -277,6 +278,7 @@ checkClosed tvs (VariableType tv) = do checkClosed tvs (TupleType tys) = mapM_ (checkClosed tvs) tys checkClosed tvs (ListType ty) = checkClosed tvs ty checkClosed tvs (ArrowType ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2] +checkClosed tvs (ParenType ty) = checkClosed tvs ty -- --------------------------------------------------------------------------- -- Auxiliary definitions diff --git a/src/Checks/TypeCheck.hs b/src/Checks/TypeCheck.hs index fe5ce1fa..6f4d7a8b 100644 --- a/src/Checks/TypeCheck.hs +++ b/src/Checks/TypeCheck.hs @@ -201,6 +201,7 @@ ft _ (VariableType _) tcs = tcs ft m (TupleType tys) tcs = foldr (ft m) tcs tys ft m (ListType ty) tcs = ft m ty tcs ft m (ArrowType ty1 ty2) tcs = ft m ty1 $ ft m ty2 $ tcs +ft m (ParenType ty) tcs = ft m ty tcs -- When a field label occurs in more than one constructor declaration of -- a data type, the compiler ensures that the label is defined @@ -412,6 +413,8 @@ nameType (ArrowType ty1 ty2) tvs = (ArrowType ty1' ty2', tvs'') (ty2', tvs'') = nameType ty2 tvs' nameType (VariableType _) [] = internalError "TypeCheck.nameType: empty ident list" +nameType (ParenType ty) tvs = (ParenType ty', tvs') + where (ty', tvs') = nameType ty tvs -- Type Inference: -- Before type checking a group of declarations, a dependency analysis is diff --git a/src/Checks/WarnCheck.hs b/src/Checks/WarnCheck.hs index caac6cf1..9ba74ea5 100644 --- a/src/Checks/WarnCheck.hs +++ b/src/Checks/WarnCheck.hs @@ -258,6 +258,7 @@ checkTypeExpr (VariableType v) = visitTypeId v checkTypeExpr (TupleType tys) = mapM_ checkTypeExpr tys checkTypeExpr (ListType ty) = checkTypeExpr ty checkTypeExpr (ArrowType ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2] +checkTypeExpr (ParenType ty) = checkTypeExpr ty -- Checks locally declared identifiers (i.e. functions and logic variables) -- for shadowing @@ -899,8 +900,7 @@ insertTypeExpr (ConstructorType _ tys) = mapM_ insertTypeExpr tys insertTypeExpr (TupleType tys) = mapM_ insertTypeExpr tys insertTypeExpr (ListType ty) = insertTypeExpr ty insertTypeExpr (ArrowType ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2] - --mapM_ insertVar (concatMap fst fs) - --maybe (return ()) insertTypeExpr rty +insertTypeExpr (ParenType ty) = insertTypeExpr ty insertConstrDecl :: ConstrDecl -> WCM () insertConstrDecl (ConstrDecl _ _ c _) = insertConsId c diff --git a/src/Exports.hs b/src/Exports.hs index 9c4ed45c..8b59d3a8 100644 --- a/src/Exports.hs +++ b/src/Exports.hs @@ -194,6 +194,7 @@ 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 (ParenType ty) xs = identsType ty xs -- After the interface declarations have been computed, the compiler -- eventually must add hidden (data) type declarations to the interface @@ -248,6 +249,7 @@ 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 (ParenType ty) tcs = usedTypesType ty tcs definedTypes :: [IDecl] -> [QualIdent] definedTypes ds = foldr definedType [] ds diff --git a/src/Generators/GenAbstractCurry.hs b/src/Generators/GenAbstractCurry.hs index 82dd9fe7..e35204c6 100644 --- a/src/Generators/GenAbstractCurry.hs +++ b/src/Generators/GenAbstractCurry.hs @@ -112,6 +112,7 @@ trTypeExpr (TupleType tys) = trTypeExpr $ case tys of trTypeExpr (ListType ty) = trTypeExpr $ ConstructorType qListId [ty] trTypeExpr (ArrowType ty1 ty2) = CFuncType <$> trTypeExpr ty1 <*> trTypeExpr ty2 +trTypeExpr (ParenType ty) = trTypeExpr ty trInfixDecl :: Decl -> GAC [COpDecl] trInfixDecl (InfixDecl _ fix mprec ops) = mapM trInfix (reverse ops) diff --git a/src/Generators/GenFlatCurry.hs b/src/Generators/GenFlatCurry.hs index 540c334b..af0f1274 100644 --- a/src/Generators/GenFlatCurry.hs +++ b/src/Generators/GenFlatCurry.hs @@ -564,6 +564,7 @@ cs2ilType ids (CS.TupleType typeexprs) _ -> let (ids', ilTypeexprs) = mapAccumL cs2ilType ids typeexprs tuplen = length ilTypeexprs in (ids', IL.TypeConstructor (qTupleId tuplen) ilTypeexprs) +cs2ilType ids (CS.ParenType ty) = cs2ilType ids ty isPublicDataDecl :: IL.Decl -> FlatState Bool isPublicDataDecl (IL.DataDecl qid _ _) = isPublic False qid diff --git a/src/Html/SyntaxColoring.hs b/src/Html/SyntaxColoring.hs index 08951cef..b745029f 100644 --- a/src/Html/SyntaxColoring.hs +++ b/src/Html/SyntaxColoring.hs @@ -323,6 +323,7 @@ idsTypeExpr (VariableType v) = [Identifier IdRefer (qualify v)] idsTypeExpr (TupleType tys) = concatMap idsTypeExpr tys idsTypeExpr (ListType ty) = idsTypeExpr ty idsTypeExpr (ArrowType ty1 ty2) = concatMap idsTypeExpr [ty1, ty2] +idsTypeExpr (ParenType ty) = idsTypeExpr ty idsFieldDecl :: FieldDecl -> [Code] idsFieldDecl (FieldDecl _ ls ty) = diff --git a/src/ModuleSummary.hs b/src/ModuleSummary.hs index 773e2e7e..005312bc 100644 --- a/src/ModuleSummary.hs +++ b/src/ModuleSummary.hs @@ -93,15 +93,16 @@ modifyTypeExpr tcEnv (ConstructorType q tys) = case qualLookupTC q tcEnv of (genTypeSynDeref (zip [0 .. ar - 1] tys) ty) _ -> ConstructorType (fromMaybe q (lookupTCId q tcEnv)) (map (modifyTypeExpr tcEnv) tys) -modifyTypeExpr _ v@(VariableType _) = v -modifyTypeExpr tcEnv (ArrowType ty1 ty2) +modifyTypeExpr _ v@(VariableType _) = v +modifyTypeExpr tcEnv (ArrowType ty1 ty2) = ArrowType (modifyTypeExpr tcEnv ty1) (modifyTypeExpr tcEnv ty2) -modifyTypeExpr tcEnv (TupleType tys) +modifyTypeExpr tcEnv (TupleType tys) | null tys = ConstructorType qUnitId [] | otherwise = ConstructorType (qTupleId $ length tys) (map (modifyTypeExpr tcEnv) tys) -modifyTypeExpr tcEnv (ListType ty) +modifyTypeExpr tcEnv (ListType ty) = ConstructorType (qualify listId) [modifyTypeExpr tcEnv ty] +modifyTypeExpr tcEnv (ParenType ty) = modifyTypeExpr tcEnv ty -- genTypeSynDeref :: [(Int, TypeExpr)] -> Type -> TypeExpr diff --git a/src/Transformations/Qual.hs b/src/Transformations/Qual.hs index 939118a3..16604585 100644 --- a/src/Transformations/Qual.hs +++ b/src/Transformations/Qual.hs @@ -102,6 +102,7 @@ qTypeExpr (TupleType tys) = TupleType <$> mapM qTypeExpr tys qTypeExpr (ListType ty) = ListType <$> qTypeExpr ty qTypeExpr (ArrowType ty1 ty2) = ArrowType <$> qTypeExpr ty1 <*> qTypeExpr ty2 +qTypeExpr (ParenType ty) = ParenType <$> qTypeExpr ty qEquation :: Qual Equation qEquation (Equation p lhs rhs) = Equation p <$> qLhs lhs <*> qRhs rhs -- GitLab