From f246e6113c6c19c6cf0e23bc405564d83b8b2826 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 29 May 2022 19:28:22 -0400 Subject: [PATCH] Allow most leading and trailing delimiters --- ...feature_leading-and-trailing-delimiters.md | 15 ++++ src/Language/PureScript/CST/Convert.hs | 12 +-- src/Language/PureScript/CST/Flatten.hs | 29 ++++--- src/Language/PureScript/CST/Parser.y | 35 ++++---- src/Language/PureScript/CST/Positions.hs | 8 +- src/Language/PureScript/CST/Traversals.hs | 4 +- src/Language/PureScript/CST/Types.hs | 17 ++-- src/Language/PureScript/CST/Utils.hs | 19 ++-- tests/purs/passing/LeadingDelimiters.purs | 86 +++++++++++++++++++ tests/purs/passing/TrailingDelimiters.purs | 74 ++++++++++++++++ 10 files changed, 250 insertions(+), 49 deletions(-) create mode 100644 CHANGELOG.d/feature_leading-and-trailing-delimiters.md create mode 100644 tests/purs/passing/LeadingDelimiters.purs create mode 100644 tests/purs/passing/TrailingDelimiters.purs diff --git a/CHANGELOG.d/feature_leading-and-trailing-delimiters.md b/CHANGELOG.d/feature_leading-and-trailing-delimiters.md new file mode 100644 index 0000000000..385624d18f --- /dev/null +++ b/CHANGELOG.d/feature_leading-and-trailing-delimiters.md @@ -0,0 +1,15 @@ +* Allow leading and trailing delimiters in many syntax positions + + PureScript's syntax contains multiple places where sequences of words or + clauses are expected, delimited by commas or vertical bars. To + facilitate editing these elements when placed on their own lines, + PureScript's parser now supports an optional leading or trailing + delimiter in most such locations, specifically: + + * Array and object literals (and patterns) + * Sum type definitions + * Object updates + * Row types + * Import and export lists + * Functional dependencies + * Compound constraints and superclasses diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 077db41867..9686d346ee 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -107,7 +107,7 @@ convertType fileName = go let ann = sourceAnnCommented fileName (lblTok a) (snd $ typeRange ty) T.RCons ann (L.Label $ lblName a) (go ty) c case labels of - Just (Separated h t) -> + Just (SeparatedExtra _ h t _) -> rowCons h $ foldr (rowCons . snd) rowTail t Nothing -> rowTail @@ -276,7 +276,7 @@ convertExpr fileName = go let ann = sourceAnnCommented fileName a c vals = case bs of - Just (Separated x xs) -> go x : (go . snd <$> xs) + Just (SeparatedExtra _ x xs _) -> go x : (go . snd <$> xs) Nothing -> [] positioned ann . AST.Literal (fst ann) $ AST.ArrayLiteral vals ExprRecord z (Wrapped a bs c) -> do @@ -286,7 +286,7 @@ convertExpr fileName = go RecordPun f -> (mkString . getIdent $ nameValue f, go . ExprIdent z $ QualifiedName (nameTok f) Nothing (nameValue f)) RecordField f _ v -> (lblName f, go v) vals = case bs of - Just (Separated x xs) -> lbl x : (lbl . snd <$> xs) + Just (SeparatedExtra _ x xs _) -> lbl x : (lbl . snd <$> xs) Nothing -> [] positioned ann . AST.Literal (fst ann) $ AST.ObjectLiteral vals ExprParens _ (Wrapped a b c) -> @@ -399,7 +399,7 @@ convertBinder fileName = go let ann = sourceAnnCommented fileName a c vals = case bs of - Just (Separated x xs) -> go x : (go . snd <$> xs) + Just (SeparatedExtra _ x xs _) -> go x : (go . snd <$> xs) Nothing -> [] positioned ann . AST.LiteralBinder (fst ann) $ AST.ArrayLiteral vals BinderRecord z (Wrapped a bs c) -> do @@ -409,7 +409,7 @@ convertBinder fileName = go RecordPun f -> (mkString . getIdent $ nameValue f, go $ BinderVar z f) RecordField f _ v -> (lblName f, go v) vals = case bs of - Just (Separated x xs) -> lbl x : (lbl . snd <$> xs) + Just (SeparatedExtra _ x xs _) -> lbl x : (lbl . snd <$> xs) Nothing -> [] positioned ann . AST.LiteralBinder (fst ann) $ AST.ObjectLiteral vals BinderParens _ (Wrapped a b c) -> @@ -442,7 +442,7 @@ convertDeclaration fileName decl = case decl of [] -> [] (st', ctor) : tl' -> ctrs st' ctor tl' ) - pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd) + pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, SeparatedExtra _ hd tl _) -> ctrs st hd tl) bd) DeclType _ (DataHead _ a vars) _ bd -> pure $ AST.TypeSynonymDeclaration ann (nameValue a) diff --git a/src/Language/PureScript/CST/Flatten.hs b/src/Language/PureScript/CST/Flatten.hs index fe20adecd3..d3fcb5fb03 100644 --- a/src/Language/PureScript/CST/Flatten.hs +++ b/src/Language/PureScript/CST/Flatten.hs @@ -10,7 +10,7 @@ flattenModule :: Module a -> DList SourceToken flattenModule m@(Module _ a b c d e f g) = pure a <> flattenName b <> - foldMap (flattenWrapped (flattenSeparated flattenExport)) c <> + foldMap (flattenWrapped (flattenSeparatedExtra flattenExport)) c <> pure d <> foldMap flattenImportDecl e <> foldMap flattenDeclaration f <> @@ -32,7 +32,7 @@ flattenClassHead (ClassHead a b c d e) = foldMap (\(f, g) -> flattenOneOrDelimited flattenConstraint f <> pure g) b <> flattenName c <> foldMap flattenTypeVarBinding d <> - foldMap (\(f, g) -> pure f <> flattenSeparated flattenClassFundep g) e + foldMap (\(f, g) -> pure f <> flattenSeparatedExtra flattenClassFundep g) e flattenClassFundep :: ClassFundep -> DList SourceToken flattenClassFundep = \case @@ -74,9 +74,9 @@ flattenBinder = \case BinderChar _ a _ -> pure a BinderString _ a _ -> pure a BinderNumber _ a b _ -> foldMap pure a <> pure b - BinderArray _ a -> flattenWrapped (foldMap (flattenSeparated flattenBinder)) a + BinderArray _ a -> flattenWrapped (foldMap (flattenSeparatedExtra flattenBinder)) a BinderRecord _ a -> - flattenWrapped (foldMap (flattenSeparated (flattenRecordLabeled flattenBinder))) a + flattenWrapped (foldMap (flattenSeparatedExtra (flattenRecordLabeled flattenBinder))) a BinderParens _ a -> flattenWrapped flattenBinder a BinderTyped _ a b c -> flattenBinder a <> pure b <> flattenType c BinderOp _ a b c -> flattenBinder a <> flattenQualifiedName b <> flattenBinder c @@ -94,7 +94,7 @@ flattenRecordUpdate :: RecordUpdate a -> DList SourceToken flattenRecordUpdate = \case RecordUpdateLeaf a b c -> flattenLabel a <> pure b <> flattenExpr c RecordUpdateBranch a b -> - flattenLabel a <> flattenWrapped (flattenSeparated flattenRecordUpdate) b + flattenLabel a <> flattenWrapped (flattenSeparatedExtra flattenRecordUpdate) b flattenLambda :: Lambda a -> DList SourceToken flattenLambda (Lambda a b c d) = @@ -139,9 +139,9 @@ flattenExpr = \case ExprChar _ a _ -> pure a ExprString _ a _ -> pure a ExprNumber _ a _ -> pure a - ExprArray _ a -> flattenWrapped (foldMap (flattenSeparated flattenExpr)) a + ExprArray _ a -> flattenWrapped (foldMap (flattenSeparatedExtra flattenExpr)) a ExprRecord _ a -> - flattenWrapped (foldMap (flattenSeparated (flattenRecordLabeled flattenExpr))) a + flattenWrapped (foldMap (flattenSeparatedExtra (flattenRecordLabeled flattenExpr))) a ExprParens _ a -> flattenWrapped flattenExpr a ExprTyped _ a b c -> flattenExpr a <> pure b <> flattenType c ExprInfix _ a b c -> flattenExpr a <> flattenWrapped flattenExpr b <> flattenExpr c @@ -149,7 +149,7 @@ flattenExpr = \case ExprOpName _ a -> flattenQualifiedName a ExprNegate _ a b -> pure a <> flattenExpr b ExprRecordAccessor _ a -> flattenRecordAccessor a - ExprRecordUpdate _ a b -> flattenExpr a <> flattenWrapped (flattenSeparated flattenRecordUpdate) b + ExprRecordUpdate _ a b -> flattenExpr a <> flattenWrapped (flattenSeparatedExtra flattenRecordUpdate) b ExprApp _ a b -> flattenExpr a <> flattenExpr b ExprLambda _ a -> flattenLambda a ExprIf _ a -> flattenIfThenElse a @@ -206,7 +206,7 @@ flattenDeclaration :: Declaration a -> DList SourceToken flattenDeclaration = \case DeclData _ a b -> flattenDataHead a <> - foldMap (\(t, cs) -> pure t <> flattenSeparated flattenDataCtor cs) b + foldMap (\(t, cs) -> pure t <> flattenSeparatedExtra flattenDataCtor cs) b DeclType _ a b c ->flattenDataHead a <> pure b <> flattenType c DeclNewtype _ a b c d -> flattenDataHead a <> pure b <> flattenName c <> flattenType d DeclClass _ a b -> @@ -242,14 +242,14 @@ flattenExport = \case flattenDataMembers :: DataMembers a -> DList SourceToken flattenDataMembers = \case DataAll _ t -> pure t - DataEnumerated _ ns -> flattenWrapped (foldMap (flattenSeparated flattenName)) ns + DataEnumerated _ ns -> flattenWrapped (foldMap (flattenSeparatedExtra flattenName)) ns flattenImportDecl :: ImportDecl a -> DList SourceToken flattenImportDecl (ImportDecl _ a b c d) = pure a <> flattenName b <> foldMap (\(mt, is) -> - foldMap pure mt <> flattenWrapped (flattenSeparated flattenImport) is) c <> + foldMap pure mt <> flattenWrapped (flattenSeparatedExtra flattenImport) is) c <> foldMap (\(t, n) -> pure t <> flattenName n) d flattenImport :: Import a -> DList SourceToken @@ -266,11 +266,14 @@ flattenWrapped k (Wrapped a b c) = pure a <> k b <> pure c flattenSeparated :: (a -> DList SourceToken) -> Separated a -> DList SourceToken flattenSeparated k (Separated a b) = k a <> foldMap (\(c, d) -> pure c <> k d) b +flattenSeparatedExtra :: (a -> DList SourceToken) -> SeparatedExtra a -> DList SourceToken +flattenSeparatedExtra k (SeparatedExtra a b c d) = foldMap pure a <> k b <> foldMap (\(e, f) -> pure e <> k f) c <> foldMap pure d + flattenOneOrDelimited :: (a -> DList SourceToken) -> OneOrDelimited a -> DList SourceToken flattenOneOrDelimited f = \case One a -> f a - Many a -> flattenWrapped (flattenSeparated f) a + Many a -> flattenWrapped (flattenSeparatedExtra f) a flattenLabeled :: (a -> DList SourceToken) -> (b -> DList SourceToken) -> Labeled a b -> DList SourceToken flattenLabeled ka kc (Labeled a b c) = ka a <> pure b <> kc c @@ -298,7 +301,7 @@ flattenType = \case flattenRow :: Row a -> DList SourceToken flattenRow (Row lbls tl) = - foldMap (flattenSeparated (flattenLabeled (pure . lblTok) flattenType)) lbls + foldMap (flattenSeparatedExtra (flattenLabeled (pure . lblTok) flattenType)) lbls <> foldMap (\(a, b) -> pure a <> flattenType b) tl flattenTypeVarBinding :: TypeVarBinding a -> DList SourceToken diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 0f800c05b2..1f5dcc50ae 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -167,13 +167,18 @@ manyOrEmpty(a) :: { [a] } sep(a, s) :: { Separated a } : sep1(a, s) { separated $1 } +sepx(a, s) :: { SeparatedExtra a } + : sep1(a, s) { separatedExtra Nothing Nothing $1 } + | sep1(a, s) s { separatedExtra Nothing (Just $2) $1 } + | s sep1(a, s) { separatedExtra (Just $1) Nothing $2 } + sep1(a, s) :: { [(SourceToken, a)] } : a %shift { [(placeholder, $1)] } | sep1(a, s) s a { ($2, $3) : $1 } delim(a, b, c, d) :: { Delimited b } : a d { Wrapped $1 Nothing $2 } - | a sep(b, c) d { Wrapped $1 (Just $2) $3 } + | a sepx(b, c) d { Wrapped $1 (Just $2) $3 } moduleName :: { Name N.ModuleName } : UPPER {% upperToModuleName $1 } @@ -340,8 +345,8 @@ typeKindedAtom :: { Type () } row :: { Row () } : {- empty -} { Row Nothing Nothing } | '|' type { Row Nothing (Just ($1, $2)) } - | sep(rowLabel, ',') { Row (Just $1) Nothing } - | sep(rowLabel, ',') '|' type { Row (Just $1) (Just ($2, $3)) } + | sepx(rowLabel, ',') { Row (Just $1) Nothing } + | sepx(rowLabel, ',') '|' type { Row (Just $1) (Just ($2, $3)) } rowLabel :: { Labeled Label (Type ()) } : label '::' type { Labeled $1 $2 $3 } @@ -409,7 +414,7 @@ expr5 :: { Expr () } expr6 :: { Expr () } : expr7 %shift { $1 } | expr7 '{' '}' { ExprApp () $1 (ExprRecord () (Wrapped $2 Nothing $3)) } - | expr7 '{' sep(recordUpdateOrLabel, ',') '}' + | expr7 '{' sepx(recordUpdateOrLabel, ',') '}' {% toRecordFields $3 >>= \case Left xs -> pure $ ExprApp () $1 (ExprRecord () (Wrapped $2 (Just xs) $4)) Right xs -> pure $ ExprRecordUpdate () $1 (Wrapped $2 xs $4) @@ -442,11 +447,11 @@ recordUpdateOrLabel :: { Either (RecordLabeled (Expr ())) (RecordUpdate ()) } : label ':' expr { Left (RecordField $1 $2 $3) } | label {% fmap (Left . RecordPun) . toName Ident $ lblTok $1 } | label '=' expr { Right (RecordUpdateLeaf $1 $2 $3) } - | label '{' sep(recordUpdate, ',') '}' { Right (RecordUpdateBranch $1 (Wrapped $2 $3 $4)) } + | label '{' sepx(recordUpdate, ',') '}' { Right (RecordUpdateBranch $1 (Wrapped $2 $3 $4)) } recordUpdate :: { RecordUpdate () } : label '=' expr { RecordUpdateLeaf $1 $2 $3 } - | label '{' sep(recordUpdate, ',') '}' { RecordUpdateBranch $1 (Wrapped $2 $3 $4) } + | label '{' sepx(recordUpdate, ',') '}' { RecordUpdateBranch $1 (Wrapped $2 $3 $4) } letBinding :: { LetBinding () } : ident '::' type { LetBindingSignature () (Labeled $1 $2 $3) } @@ -620,7 +625,7 @@ declElse :: { SourceToken } exports :: { Maybe (DelimitedNonEmpty (Export ())) } : {- empty -} { Nothing } - | '(' sep(export, ',') ')' { Just (Wrapped $1 $2 $3) } + | '(' sepx(export, ',') ')' { Just (Wrapped $1 $2 $3) } export :: { Export () } : ident { ExportValue () $1 } @@ -634,7 +639,7 @@ export :: { Export () } dataMembers :: { (DataMembers ()) } : '(..)' { DataAll () $1 } | '(' ')' { DataEnumerated () (Wrapped $1 Nothing $2) } - | '(' sep(properName, ',') ')' { DataEnumerated () (Wrapped $1 (Just \$ getProperName <\$> $2) $3) } + | '(' sepx(properName, ',') ')' { DataEnumerated () (Wrapped $1 (Just \$ getProperName <\$> $2) $3) } importDecl :: { ImportDecl () } : 'import' moduleName imports { ImportDecl () $1 $2 $3 Nothing } @@ -642,8 +647,8 @@ importDecl :: { ImportDecl () } imports :: { Maybe (Maybe SourceToken, DelimitedNonEmpty (Import ())) } : {- empty -} { Nothing } - | '(' sep(import, ',') ')' { Just (Nothing, Wrapped $1 $2 $3) } - | 'hiding' '(' sep(import, ',') ')' { Just (Just $1, Wrapped $2 $3 $4) } + | '(' sepx(import, ',') ')' { Just (Nothing, Wrapped $1 $2 $3) } + | 'hiding' '(' sepx(import, ',') ')' { Just (Just $1, Wrapped $2 $3 $4) } import :: { Import () } : ident { ImportValue () $1 } @@ -655,7 +660,7 @@ import :: { Import () } decl :: { Declaration () } : dataHead { DeclData () $1 Nothing } - | dataHead '=' sep(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) } + | dataHead '=' sepx(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) } | typeHead '=' type {% checkNoWildcards $3 *> pure (DeclType () $1 $2 $3) } | newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 (getProperName $3) $4) } | classHead { either id (\h -> DeclClass () h Nothing) $1 } @@ -714,12 +719,12 @@ classSignature :: { Labeled (Name (N.ProperName 'N.TypeName)) (Type ()) } classSuper :: { (OneOrDelimited (Constraint ()), SourceToken) } : constraints '<=' {%^ revert $ pure ($1, $2) } -classNameAndFundeps :: { (Name (N.ProperName 'N.ClassName), [TypeVarBinding ()], Maybe (SourceToken, Separated ClassFundep)) } +classNameAndFundeps :: { (Name (N.ProperName 'N.ClassName), [TypeVarBinding ()], Maybe (SourceToken, SeparatedExtra ClassFundep)) } : properName manyOrEmpty(typeVarBinding) fundeps {%^ revert $ pure (getProperName $1, $2, $3) } -fundeps :: { Maybe (SourceToken, Separated ClassFundep) } +fundeps :: { Maybe (SourceToken, SeparatedExtra ClassFundep) } : {- empty -} { Nothing } - | '|' sep(fundep, ',') { Just ($1, $2) } + | '|' sepx(fundep, ',') { Just ($1, $2) } fundep :: { ClassFundep } : '->' many(ident) { FundepDetermined $1 $2 } @@ -740,7 +745,7 @@ instHead :: { InstanceHead () } constraints :: { OneOrDelimited (Constraint ()) } : constraint { One $1 } - | '(' sep(constraint, ',') ')' { Many (Wrapped $1 $2 $3) } + | '(' sepx(constraint, ',') ')' { Many (Wrapped $1 $2 $3) } constraint :: { Constraint () } : qualProperName manyOrEmpty(typeAtom) {% for_ $2 checkNoWildcards *> for_ $2 checkNoForalls *> pure (Constraint () (getQualifiedProperName $1) $2) } diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs index 88630805f9..14e554f50e 100644 --- a/src/Language/PureScript/CST/Positions.hs +++ b/src/Language/PureScript/CST/Positions.hs @@ -98,6 +98,10 @@ sepLast :: Separated a -> a sepLast (Separated hd []) = hd sepLast (Separated _ tl) = snd $ last tl +sepXLast :: SeparatedExtra a -> a +sepXLast (SeparatedExtra _ hd [] _) = hd +sepXLast (SeparatedExtra _ _ tl _) = snd $ last tl + type TokenRange = (SourceToken, SourceToken) toSourceRange :: TokenRange -> SourceRange @@ -160,7 +164,7 @@ dataMembersRange = \case declRange :: Declaration a -> TokenRange declRange = \case DeclData _ hd ctors - | Just (_, cs) <- ctors -> (fst start, snd . dataCtorRange $ sepLast cs) + | Just (_, cs) <- ctors -> (fst start, fromMaybe (snd . dataCtorRange $ sepXLast cs) $ sepXTrailing cs) | otherwise -> start where start = dataHeadRange hd DeclType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b) @@ -191,7 +195,7 @@ dataCtorRange (DataCtor _ name fields) classHeadRange :: ClassHead a -> TokenRange classHeadRange (ClassHead kw _ name vars fdeps) - | Just (_, fs) <- fdeps = (kw, snd .classFundepRange $ sepLast fs) + | Just (_, fs) <- fdeps = (kw, fromMaybe (snd . classFundepRange $ sepXLast fs) $ sepXTrailing fs) | [] <- vars = (kw, snd $ nameRange name) | otherwise = (kw, snd . typeVarBindingRange $ last vars) diff --git a/src/Language/PureScript/CST/Traversals.hs b/src/Language/PureScript/CST/Traversals.hs index 6d5627f8ac..5441afc9bc 100644 --- a/src/Language/PureScript/CST/Traversals.hs +++ b/src/Language/PureScript/CST/Traversals.hs @@ -4,8 +4,8 @@ import Prelude import Language.PureScript.CST.Types -everythingOnSeparated :: (r -> r -> r) -> (a -> r) -> Separated a -> r -everythingOnSeparated op k (Separated hd tl) = go hd tl +everythingOnSeparated :: (r -> r -> r) -> (a -> r) -> SeparatedExtra a -> r +everythingOnSeparated op k (SeparatedExtra _ hd tl _) = go hd tl where go a [] = k a go a (b : bs) = k a `op` go (snd b) bs diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index 7450058e61..4887a24315 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -117,14 +117,21 @@ data Separated a = Separated , sepTail :: [(SourceToken, a)] } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +data SeparatedExtra a = SeparatedExtra + { sepXLeading :: Maybe SourceToken + , sepXHead :: a + , sepXTail :: [(SourceToken, a)] + , sepXTrailing :: Maybe SourceToken + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + data Labeled a b = Labeled { lblLabel :: a , lblSep :: SourceToken , lblValue :: b } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) -type Delimited a = Wrapped (Maybe (Separated a)) -type DelimitedNonEmpty a = Wrapped (Separated a) +type Delimited a = Wrapped (Maybe (SeparatedExtra a)) +type DelimitedNonEmpty a = Wrapped (SeparatedExtra a) data OneOrDelimited a = One a @@ -163,7 +170,7 @@ data Constraint a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data Row a = Row - { rowLabels :: Maybe (Separated (Labeled Label (Type a))) + { rowLabels :: Maybe (SeparatedExtra (Labeled Label (Type a))) , rowTail :: Maybe (SourceToken, Type a) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) @@ -193,7 +200,7 @@ data DataMembers a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data Declaration a - = DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a))) + = DeclData a (DataHead a) (Maybe (SourceToken, SeparatedExtra (DataCtor a))) | DeclType a (DataHead a) SourceToken (Type a) | DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a) | DeclClass a (ClassHead a) (Maybe (SourceToken, NonEmpty (Labeled (Name Ident) (Type a)))) @@ -250,7 +257,7 @@ data ClassHead a = ClassHead , clsSuper :: Maybe (OneOrDelimited (Constraint a), SourceToken) , clsName :: Name (N.ProperName 'N.ClassName) , clsVars :: [TypeVarBinding a] - , clsFundeps :: Maybe (SourceToken, Separated ClassFundep) + , clsFundeps :: Maybe (SourceToken, SeparatedExtra ClassFundep) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data ClassFundep diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index 9c31d5fd8b..29e604b04e 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -110,6 +110,13 @@ separated = go [] go accum (x : xs) = go (x : accum) xs go _ [] = internalError "Separated should not be empty" +separatedExtra :: Maybe SourceToken -> Maybe SourceToken -> [(SourceToken, a)] -> SeparatedExtra a +separatedExtra lead trail = go [] + where + go accum [(_, a)] = SeparatedExtra lead a accum trail + go accum (x : xs) = go (x : accum) xs + go _ [] = internalError "SeparatedExtra should not be empty" + internalError :: String -> a internalError = error . ("Internal parser error: " <>) @@ -221,13 +228,13 @@ toBinderConstructor = \case toRecordFields :: Monoid a - => Separated (Either (RecordLabeled (Expr a)) (RecordUpdate a)) - -> Parser (Either (Separated (RecordLabeled (Expr a))) (Separated (RecordUpdate a))) + => SeparatedExtra (Either (RecordLabeled (Expr a)) (RecordUpdate a)) + -> Parser (Either (SeparatedExtra (RecordLabeled (Expr a))) (SeparatedExtra (RecordUpdate a))) toRecordFields = \case - Separated (Left a) as -> - Left . Separated a <$> traverse (traverse unLeft) as - Separated (Right a) as -> - Right . Separated a <$> traverse (traverse unRight) as + SeparatedExtra ld (Left a) as tr -> + Left . flip (SeparatedExtra ld a) tr <$> traverse (traverse unLeft) as + SeparatedExtra ld (Right a) as tr -> + Right . flip (SeparatedExtra ld a) tr <$> traverse (traverse unRight) as where unLeft (Left tok) = pure tok unLeft (Right tok) = diff --git a/tests/purs/passing/LeadingDelimiters.purs b/tests/purs/passing/LeadingDelimiters.purs new file mode 100644 index 0000000000..775f61ca8f --- /dev/null +++ b/tests/purs/passing/LeadingDelimiters.purs @@ -0,0 +1,86 @@ +module Main + ( + , main + ) where + +import Prelude + hiding + ( + , map + , unit + ) +import Data.Maybe + ( + , Maybe( + , Nothing + , Just + ) + ) +import Effect.Console + ( + , log + ) + +data X = + | A + +data Y = + | B + | C + +alpha :: Array X +alpha = + [ + , A + ] + +bravo :: + { + , foo :: Y + } +bravo = + { + , foo: B + } + +charlie :: Array X -> Int +charlie + [ + , A + ] + = 1 +charlie _ = 0 + +delta + :: Record ( + , foo :: Y + ) + -> Y +delta + { + , foo + } + = foo + +setBarToC + :: { + , foo :: Y + | () + } + -> { + , foo :: Y + } +setBarToC x = + x { + , foo = C + } + +class + ( + , Functor f + , Functor g + ) <= F2 f g | + , f -> g + , g -> f + +main = log "Done" diff --git a/tests/purs/passing/TrailingDelimiters.purs b/tests/purs/passing/TrailingDelimiters.purs new file mode 100644 index 0000000000..8b9e0e2985 --- /dev/null +++ b/tests/purs/passing/TrailingDelimiters.purs @@ -0,0 +1,74 @@ +module Main ( + main, +) where + +import Prelude hiding ( + map, + unit, +) +import Data.Maybe ( + Maybe( + Nothing, + Just, + ), +) +import Effect.Console ( + log, +) + +data X = + A | + +data Y = + B | + C | + +alpha :: Array X +alpha = [ + A, +] + +bravo :: { + foo :: Y, +} +bravo = { + foo: B, +} + +charlie :: Array X -> Int +charlie [ + A, + ] + = 1 +charlie _ = 0 + +delta + :: Record ( + foo :: Y, + ) + -> Y +delta { + foo, + } + = foo + +setBarToC + :: { + foo :: Y, + | () + } + -> { + foo :: Y, + } +setBarToC x = x { + foo = C, +} + +class ( + Functor f, + Functor g, +) <= F2 f g | + f -> g, + g -> f, + +main = log "Done"