Commit 58e3e833 authored by Fredrik Wieczerkowski's avatar Fredrik Wieczerkowski

Re-apply 'remove-exist-quant'

- Merge branch 'fix-warnings' into 'master'
  Fix some compiler warnings in the syntax modules
  See merge request !10
- Merge branch 'remove-exist-quant' into 'master'
  Remove support for existential quantified type variables in data type declarations
  See merge request !11
- Update Pretty and Binary instances for ConstrDecl
Co-authored-by: Finn Teegen's avatarFinn Teegen <fte@informatik.uni-kiel.de>
parent a4c373d8
......@@ -147,13 +147,12 @@ data CTypeDecl
-- the name written in the source program).
type CTVarIName = (Int, String)
-- |A constructor declaration consists of a list of existentially
-- quantified type variables, a context, the name of the constructor
-- |A constructor declaration consists of the name of the constructor
-- and a list of the argument types of the constructor.
-- The arity equals the number of types.
data CConsDecl
= CCons [CTVarIName] CContext QName CVisibility [CTypeExpr]
| CRecord [CTVarIName] CContext QName CVisibility [CFieldDecl]
= CCons QName CVisibility [CTypeExpr]
| CRecord QName CVisibility [CFieldDecl]
deriving (Eq, Read, Show)
-- |A record field declaration consists of the name of the
......
......@@ -71,7 +71,6 @@ instance Binary KnownExtension where
data KnownExtension
= AnonFreeVars -- ^ anonymous free variables
| CPP -- ^ C preprocessor
| ExistentialQuantification -- ^ existential quantification
| FunctionalPatterns -- ^ functional patterns
| NegativeLiterals -- ^ negative literals
| NoImplicitPrelude -- ^ no implicit import of the prelude
......
......@@ -99,12 +99,12 @@ instance Equiv IDecl where
_ =~= _ = False
instance Equiv ConstrDecl where
ConstrDecl _ evs1 cx1 c1 tys1 =~= ConstrDecl _ evs2 cx2 c2 tys2
= c1 == c2 && evs1 == evs2 && cx1 == cx2 && tys1 == tys2
ConOpDecl _ evs1 cx1 ty11 op1 ty12 =~= ConOpDecl _ evs2 cx2 ty21 op2 ty22
= op1 == op2 && evs1 == evs2 && cx1 == cx2 && ty11 == ty21 && ty12 == ty22
RecordDecl _ evs1 cx1 c1 fs1 =~= RecordDecl _ evs2 cx2 c2 fs2
= c1 == c2 && evs1 == evs2 && cx1 == cx2 && fs1 `eqvList` fs2
ConstrDecl _ c1 tys1 =~= ConstrDecl _ c2 tys2
= c1 == c2 && tys1 == tys2
ConOpDecl _ ty11 op1 ty12 =~= ConOpDecl _ ty21 op2 ty22
= op1 == op2 && ty11 == ty21 && ty12 == ty22
RecordDecl _ c1 fs1 =~= RecordDecl _ c2 fs2
= c1 == c2 && fs1 `eqvList` fs2
_ =~= _ = False
instance Equiv FieldDecl where
......@@ -159,10 +159,10 @@ instance FixInterface IDecl where
fix _ d = d
instance FixInterface ConstrDecl where
fix tcs (ConstrDecl p evs cx c tys) = ConstrDecl p evs cx c (fix tcs tys)
fix tcs (ConOpDecl p evs cx ty1 op ty2) = ConOpDecl p evs cx (fix tcs ty1)
op (fix tcs ty2)
fix tcs (RecordDecl p evs cx c fs) = RecordDecl p evs cx c (fix tcs fs)
fix tcs (ConstrDecl p c tys) = ConstrDecl p c (fix tcs tys)
fix tcs (ConOpDecl p ty1 op ty2) = ConOpDecl p (fix tcs ty1)
op (fix tcs ty2)
fix tcs (RecordDecl p c fs) = RecordDecl p c (fix tcs fs)
instance FixInterface FieldDecl where
fix tcs (FieldDecl p ls ty) = FieldDecl p ls (fix tcs ty)
......
......@@ -340,8 +340,7 @@ typeDeclLhs :: (Span -> Ident -> [Ident] -> a) -> Category
typeDeclLhs f kw = f <$> tokenSpan kw <*> tycon <*> many anonOrTyvar
constrDecl :: Parser a Token ConstrDecl
constrDecl = spanPosition <**> (existVars
<**> optContext (\cx sp f -> f sp cx) constr)
constrDecl = spanPosition <**> constr
where
constr = conId <**> identDecl
<|> tokenSpan LeftParen <**> parenDecl
......@@ -357,16 +356,16 @@ constrDecl = spanPosition <**> (existVars
conType f tys c = f $ foldl mkApply (mkConstructorType $ qualify c) tys
mkApply t1 t2 = updateEndPos $ ApplyType (fromSrcSpan (getSrcSpan t1)) t1 t2
mkConstructorType qid = ConstructorType (fromSrcSpan (getSrcSpan qid)) qid
conDecl tys c ss1 cx (ss2, tvs) sp = updateEndPos $
ConstrDecl (spanInfo sp (ss2 ++ ss1)) tvs cx c tys
conOpDecl op ty2 ty1 ss1 cx (ss2, tvs) sp = updateEndPos $
ConOpDecl (spanInfo sp (ss2 ++ ss1)) tvs cx ty1 op ty2
conOpDeclParen op ty2 sp1 ty1 sp2 ss1 cx (ss2, tvs) sp5 = updateEndPos $
ConOpDecl (spanInfo sp5 (ss2 ++ ss1 ++ [sp2, sp1])) tvs cx ty1 op ty2
conOpDeclPrefix op sp1 ty1 ty2 sp2 ss1 cx (ss2, tvs) sp3 = updateEndPos $
ConOpDecl (spanInfo sp3 (ss2 ++ ss1 ++ [sp2,sp1])) tvs cx ty1 op ty2
recDecl ((fs, ss), sp1, sp2) c ss1 cx (ss2, tvs) sp3 = updateEndPos $
RecordDecl (spanInfo sp3 (ss2 ++ ss1 ++ (sp1: (ss ++ [sp2])))) tvs cx c fs
conDecl tys c sp = updateEndPos $
ConstrDecl (SpanInfo sp []) c tys
conOpDecl op ty2 ty1 sp = updateEndPos $
ConOpDecl (SpanInfo sp []) ty1 op ty2
conOpDeclParen op ty2 sp1 ty1 sp2 sp5 = updateEndPos $
ConOpDecl (SpanInfo sp5 [sp2, sp1]) ty1 op ty2
conOpDeclPrefix op sp1 ty1 ty2 sp2 sp3 = updateEndPos $
ConOpDecl (SpanInfo sp3 [sp2, sp1]) ty1 op ty2
recDecl ((fs, ss), sp1, sp2) c sp3 = updateEndPos $
RecordDecl (SpanInfo sp3 (sp1 : ss ++ [sp2])) c fs
fieldDecl :: Parser a Token FieldDecl
fieldDecl = mkFieldDecl <$> spanPosition <*> labels
......@@ -395,13 +394,6 @@ deriv = (addSpan <$> tokenSpan KW_deriving <*> classes) `opt` ([], [])
<*> (qtycls `sepBySp` comma)
<*> tokenSpan RightParen)
-- Parsing of existential variables
existVars :: Parser a Token ([Span], [Ident])
existVars = mk <$> tokenSpan Id_forall <*> many1 tyvar <*>
tokenSpan SymDot
`opt` ([],[])
where mk sp1 a sp2 = ([sp1,sp2], a)
functionDecl :: Parser a Token (Decl ())
functionDecl = spanPosition <**> decl
where decl = fun `sepBy1Sp` comma <**> funListDecl <|?> funRule
......@@ -1370,9 +1362,6 @@ parensSp p = (\sp1 b sp2 -> (b, sp1, sp2))
<*> p
<*> tokenSpan RightParen
backquotes :: Parser a Token b -> Parser a Token b
backquotes p = between backquote p expectBackquote
backquotesSp :: Parser a Token b -> Parser a Token (b, Span, Span)
backquotesSp p = (\sp1 b sp2 -> (b, sp1, sp2))
<$> tokenSpan Backquote
......
......@@ -148,18 +148,12 @@ ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc
ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)
instance Pretty ConstrDecl where
pPrint (ConstrDecl _ tvs cx c tys) =
sep [ ppQuantifiedVars tvs <+> ppContext cx
, ppIdent c <+> fsep (map (pPrintPrec 2) tys)
]
pPrint (ConOpDecl _ tvs cx ty1 op ty2) =
sep [ ppQuantifiedVars tvs <+> ppContext cx
, pPrintPrec 1 ty1, ppInfixOp op <+> pPrintPrec 1 ty2
]
pPrint (RecordDecl _ tvs cx c fs) =
sep [ ppQuantifiedVars tvs <+> ppContext cx
, ppIdent c <+> record (list (map pPrint fs))
]
pPrint (ConstrDecl _ c tys) =
sep [ ppIdent c <+> fsep (map (pPrintPrec 2) tys) ]
pPrint (ConOpDecl _ ty1 op ty2) =
sep [ pPrintPrec 1 ty1, ppInfixOp op <+> pPrintPrec 1 ty2 ]
pPrint (RecordDecl _ c fs) =
sep [ ppIdent c <+> record (list (map pPrint fs)) ]
instance Pretty FieldDecl where
pPrint (FieldDecl _ ls ty) = list (map ppIdent ls)
......
......@@ -238,28 +238,22 @@ showsInstanceType :: InstanceType -> ShowS
showsInstanceType = showsTypeExpr
showsConsDecl :: ConstrDecl -> ShowS
showsConsDecl (ConstrDecl spi idents context ident types)
showsConsDecl (ConstrDecl spi ident types)
= showsString "(ConstrDecl "
. showsSpanInfo spi . space
. showsList showsIdent idents . space
. showsContext context . space
. showsIdent ident . space
. showsList showsTypeExpr types
. showsString ")"
showsConsDecl (ConOpDecl spi idents context ty1 ident ty2)
showsConsDecl (ConOpDecl spi ty1 ident ty2)
= showsString "(ConOpDecl "
. showsSpanInfo spi . space
. showsList showsIdent idents . space
. showsContext context . space
. showsTypeExpr ty1 . space
. showsIdent ident . space
. showsTypeExpr ty2
. showsString ")"
showsConsDecl (RecordDecl spi idents context ident fs)
showsConsDecl (RecordDecl spi ident fs)
= showsString "(RecordDecl "
. showsSpanInfo spi . space
. showsList showsIdent idents . space
. showsContext context . space
. showsIdent ident . space
. showsList showsFieldDecl fs
. showsString ")"
......
......@@ -185,9 +185,9 @@ data Infix
-- |Constructor declaration for algebraic data types
data ConstrDecl
= ConstrDecl SpanInfo [Ident] Context Ident [TypeExpr]
| ConOpDecl SpanInfo [Ident] Context TypeExpr Ident TypeExpr
| RecordDecl SpanInfo [Ident] Context Ident [FieldDecl]
= ConstrDecl SpanInfo Ident [TypeExpr]
| ConOpDecl SpanInfo TypeExpr Ident TypeExpr
| RecordDecl SpanInfo Ident [FieldDecl]
deriving (Eq, Read, Show)
-- |Constructor declaration for renaming types (newtypes)
......@@ -653,23 +653,23 @@ instance HasSpanInfo Import where
updateEndPos i@(ImportTypeAll _ _) = i
instance HasSpanInfo ConstrDecl where
getSpanInfo (ConstrDecl sp _ _ _ _) = sp
getSpanInfo (ConOpDecl sp _ _ _ _ _) = sp
getSpanInfo (RecordDecl sp _ _ _ _) = sp
getSpanInfo (ConstrDecl sp _ _) = sp
getSpanInfo (ConOpDecl sp _ _ _) = sp
getSpanInfo (RecordDecl sp _ _) = sp
setSpanInfo sp (ConstrDecl _ tvar ctx idt ty) = ConstrDecl sp tvar ctx idt ty
setSpanInfo sp (ConOpDecl _ tvar ctx ty1 idt ty2) = ConOpDecl sp tvar ctx ty1 idt ty2
setSpanInfo sp (RecordDecl _ tvar ctx idt fd) = RecordDecl sp tvar ctx idt fd
setSpanInfo sp (ConstrDecl _ idt ty) = ConstrDecl sp idt ty
setSpanInfo sp (ConOpDecl _ ty1 idt ty2) = ConOpDecl sp ty1 idt ty2
setSpanInfo sp (RecordDecl _ idt fd) = RecordDecl sp idt fd
updateEndPos c@(ConstrDecl _ _ _ _ (t:ts)) =
updateEndPos c@(ConstrDecl _ _ (t:ts)) =
setEndPosition (getSrcSpanEnd (last (t:ts))) c
updateEndPos c@(ConstrDecl _ _ _ idt _) =
updateEndPos c@(ConstrDecl _ idt _) =
setEndPosition (incr (getPosition idt) (identLength idt - 1)) c
updateEndPos c@(ConOpDecl _ _ _ _ _ ty) =
updateEndPos c@(ConOpDecl _ _ _ ty) =
setEndPosition (getSrcSpanEnd ty) c
updateEndPos c@(RecordDecl (SpanInfo _ ss) _ _ _ _) =
updateEndPos c@(RecordDecl (SpanInfo _ ss) _ _) =
setEndPosition (end (last ss)) c
updateEndPos c@(RecordDecl _ _ _ _ _) = c
updateEndPos c@(RecordDecl _ _ _) = c
instance HasSpanInfo NewConstrDecl where
getSpanInfo (NewConstrDecl sp _ _) = sp
......@@ -1242,19 +1242,19 @@ instance Binary Infix where
_ -> fail "Invalid encoding for Infix"
instance Binary ConstrDecl where
put (ConstrDecl spi tvar ctx idt ty) =
putWord8 0 >> put spi >> put tvar >> put ctx >> put idt >> put ty
put (ConOpDecl spi tvar ctx ty1 idt ty2) =
putWord8 1 >> put spi >> put tvar >> put ctx >> put ty1 >> put idt >> put ty2
put (RecordDecl spi tvar ctx idt fs) =
putWord8 2 >> put spi >> put tvar >> put ctx >> put idt >> put fs
put (ConstrDecl spi idt tys) =
putWord8 0 >> put spi >> put idt >> put tys
put (ConOpDecl spi ty1 idt ty2) =
putWord8 1 >> put spi >> put ty1 >> put idt >> put ty2
put (RecordDecl spi idt fs) =
putWord8 2 >> put spi >> put idt >> put fs
get = do
x <- getWord8
case x of
0 -> ConstrDecl <$> get <*> get <*> get <*> get <*> get
1 -> ConOpDecl <$> get <*> get <*> get <*> get <*> get <*> get
2 -> RecordDecl <$> get <*> get <*> get <*> get <*> get
0 -> liftM3 ConstrDecl get get get
1 -> ConOpDecl <$> get <*> get <*> get <*> get
2 -> liftM3 RecordDecl get get get
_ -> fail "Invalid encoding for ConstrDecl"
instance Binary NewConstrDecl where
......
......@@ -39,7 +39,6 @@ module Curry.Syntax.Utils
import Control.Monad.State
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.SpanInfo
import Curry.Files.Filenames (takeBaseName)
import Curry.Syntax.Extension
......@@ -212,9 +211,9 @@ opName (InfixConstr _ c ) = c
-- | Get the identifier of a constructor declaration
constrId :: ConstrDecl -> Ident
constrId (ConstrDecl _ _ _ c _) = c
constrId (ConOpDecl _ _ _ _ op _) = op
constrId (RecordDecl _ _ _ c _) = c
constrId (ConstrDecl _ c _) = c
constrId (ConOpDecl _ _ op _) = op
constrId (RecordDecl _ c _) = c
-- | Get the identifier of a newtype constructor declaration
nconstrId :: NewConstrDecl -> Ident
......@@ -228,9 +227,9 @@ nconstrType (NewRecordDecl _ _ (_, ty)) = ty
-- | Get record label identifiers of a constructor declaration
recordLabels :: ConstrDecl -> [Ident]
recordLabels (ConstrDecl _ _ _ _ _) = []
recordLabels (ConOpDecl _ _ _ _ _ _) = []
recordLabels (RecordDecl _ _ _ _ fs) = [l | FieldDecl _ ls _ <- fs, l <- ls]
recordLabels (ConstrDecl _ _ _) = []
recordLabels (ConOpDecl _ _ _ _) = []
recordLabels (RecordDecl _ _ fs) = [l | FieldDecl _ ls _ <- fs, l <- ls]
-- | Get record label identifier of a newtype constructor declaration
nrecordLabels :: NewConstrDecl -> [Ident]
......
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