6fd4899 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Merge pull request #1861 from purescript/1846

#1846, start work on '_ - 1' syntax for sections

commit6fd48997c797d582a5230b21e586be0f3ec2eb21 authorPhil Freeman <paf31@cantab.net> dateSat 20 Feb 2016, 16:56 (11 years ago) parentefc697d 0dc8a34

11 files changed+143−82

compare with golang

unifiedsplit

examples/failing/AnonArgument1.purs+5 examples/failing/AnonArgument2.purs+7 examples/failing/AnonArgument3.purs+5 examples/passing/ExplicitOperatorSections.purs+14 src/Language/PureScript/AST/Declarations.hs+7−10 src/Language/PureScript/AST/Traversals.hs+1−15 src/Language/PureScript/Errors.hs+53−20 src/Language/PureScript/Linter.hs+1 src/Language/PureScript/Parser/Declarations.hs+13−19 src/Language/PureScript/Pretty/Values.hs+1−3 src/Language/PureScript/Sugar/ObjectWildcards.hs+36−15

examples/failing/AnonArgument1.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldFailWith IncorrectAnonymousArgument

2+module Main where

4+test :: Int -> Int

5+test = _

examples/failing/AnonArgument2.pursnew file+7

@@ -0,0 +1,7 @@

1+-- @shouldFailWith IncorrectAnonymousArgument

2+module Main where

4+import Prelude

6+test :: Int -> Int

7+test = 1 + 2 * _

examples/failing/AnonArgument3.pursnew file+5

@@ -0,0 +1,5 @@

1+-- @shouldFailWith IncorrectAnonymousArgument

2+module Main where

4+test :: Int -> Int

5+test = 1 + _

examples/passing/ExplicitOperatorSections.pursnew file+14

@@ -0,0 +1,14 @@

1+module Main where

3+import Prelude

5+subtractOne :: Int -> Int

6+subtractOne = (_ - 1)

8+addOne :: Int -> Int

9+addOne = (1 + _)

10+

11+named :: Int -> Int

12+named = (_ `sub` 1)

13+

14+main = Control.Monad.Eff.Console.log "Done"

src/Language/PureScript/AST/Declarations.hs+7−10

@@ -337,6 +337,9 @@ data Expr

337337 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

338338 -- will be removed.

339339 --

340+ -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents

341+ -- certain traversals from matching.

342+ --

340343 | Parens Expr

341344 -- |

342345 -- Operator section. This will be removed during desugaring and replaced with a partially applied

@@ -352,11 +355,6 @@ data Expr

352355 --

353356 | ObjectLiteral [(String, Expr)]

354357 -- |

355− -- An object constructor (object literal with underscores). This will be removed during

356− -- desugaring and expanded into a lambda that returns an object literal.

357− --

358− | ObjectConstructor [(String, Maybe Expr)]

359− -- |

360358 -- An object property getter (e.g. `_.x`). This will be removed during

361359 -- desugaring and expanded into a lambda that reads a property from an object.

362360 --

@@ -370,11 +368,6 @@ data Expr

370368 --

371369 | ObjectUpdate Expr [(String, Expr)]

372370 -- |

373− -- Partial record updater. This will be removed during desugaring and

374− -- expanded into a lambda that returns an object update.

375− --

376− | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]

377− -- |

378371 -- Function introduction

379372 --

380373 | Abs (Either Ident Binder) Expr

@@ -433,6 +426,10 @@ data Expr

433426 --

434427 | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]

435428 -- |

429+ -- A placeholder for an anonymous function argument

430+ --

431+ | AnonymousArgument

432+ -- |

436433 -- A value with source position information

437434 --

438435 | PositionedValue SourceSpan [Comment] Expr

src/Language/PureScript/AST/Traversals.hs+1−15

@@ -23,7 +23,7 @@ import Data.Foldable (fold)

2323import qualified Data.Set as S

2424

2525import Control.Monad

26−import Control.Arrow ((***), (+++), second)

26+import Control.Arrow ((***), (+++))

2727

2828import Language.PureScript.AST.Binders

2929import Language.PureScript.AST.Declarations

@@ -54,11 +54,9 @@ everywhereOnValues f g h = (f', g', h')

5454 g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))

5555 g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

5656 g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

57− g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))

5857 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

5958 g' (Accessor prop v) = g (Accessor prop (g' v))

6059 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

61− g' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (fmap g')) vs))

6260 g' (Abs name v) = g (Abs name (g' v))

6361 g' (App v1 v2) = g (App (g' v1) (g' v2))

6462 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

@@ -112,11 +110,9 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

112110 g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))

113111 g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs

114112 g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs

115− g' (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g' <=< g)) vs

116113 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

117114 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

118115 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

119− g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> traverse (sndM $ maybeM (g' <=< g)) vs

120116 g' (Abs name v) = Abs name <$> (g v >>= g')

121117 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

122118 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')

@@ -165,11 +161,9 @@ everywhereOnValuesM f g h = (f', g', h')

165161 g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g

166162 g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g

167163 g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g

168− g' (ObjectConstructor vs) = (ObjectConstructor <$> traverse (sndM $ maybeM g') vs) >>= g

169164 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

170165 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

171166 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

172− g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> traverse (sndM $ maybeM g') vs) >>= g

173167 g' (Abs name v) = (Abs name <$> g' v) >>= g

174168 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

175169 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

@@ -221,11 +215,9 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

221215 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1

222216 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

223217 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

224− g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))

225218 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

226219 g' v@(Accessor _ v1) = g v <> g' v1

227220 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

228− g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs))

229221 g' v@(Abs _ v1) = g v <> g' v1

230222 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

231223 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

@@ -288,11 +280,9 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

288280 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

289281 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

290282 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

291− g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))

292283 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

293284 g' s (Accessor _ v1) = g'' s v1

294285 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

295− g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs))

296286 g' s (Abs _ v1) = g'' s v1

297287 g' s (App v1 v2) = g'' s v1 <> g'' s v2

298288 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3

@@ -358,11 +348,9 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

358348 g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)

359349 g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs

360350 g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs

361− g' s (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g'' s)) vs

362351 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

363352 g' s (Accessor prop v) = Accessor prop <$> g'' s v

364353 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

365− g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> traverse (sndM $ maybeM (g'' s)) vs

366354 g' s (Abs name v) = Abs name <$> g'' s v

367355 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

368356 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3

@@ -440,11 +428,9 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

440428 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

441429 g' s (ArrayLiteral vs) = foldMap (g'' s) vs

442430 g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs

443− g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs)

444431 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

445432 g' s (Accessor _ v1) = g'' s v1

446433 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

447− g' s (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs)

448434 g' s (Abs (Left name) v1) =

449435 let s' = S.insert name s

450436 in g'' s' v1

src/Language/PureScript/Errors.hs+53−20

@@ -24,6 +24,7 @@ import Control.Arrow ((&&&))

2424import Language.PureScript.Crash

2525import Language.PureScript.AST

2626import Language.PureScript.Pretty

27+import Language.PureScript.Pretty.Common (before)

2728import Language.PureScript.Types

2829import Language.PureScript.Names

2930import Language.PureScript.Kinds

@@ -128,6 +129,7 @@ data SimpleErrorMessage

128129 | UnusedDctorImport (ProperName 'TypeName)

129130 | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName]

130131 | DeprecatedOperatorDecl String

132+ | DeprecatedOperatorSection Expr (Either Expr Expr)

131133 | DeprecatedQualifiedSyntax ModuleName ModuleName

132134 | DeprecatedClassImport ModuleName (ProperName 'ClassName)

133135 | DeprecatedClassExport (ProperName 'ClassName)

@@ -142,6 +144,7 @@ data SimpleErrorMessage

142144 | ImplicitImport ModuleName [DeclarationRef]

143145 | HidingImport ModuleName [DeclarationRef]

144146 | CaseBinderLengthDiffers Int [Binder]

147+ | IncorrectAnonymousArgument

145148 deriving (Show)

146149

147150-- | Error message hints, providing more detailed information about failure.

@@ -303,6 +306,7 @@ errorCode em = case unwrapErrorMessage em of

303306 UnusedDctorImport{} -> "UnusedDctorImport"

304307 UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

305308 DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl"

309+ DeprecatedOperatorSection{} -> "DeprecatedOperatorSection"

306310 DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax"

307311 DeprecatedClassImport{} -> "DeprecatedClassImport"

308312 DeprecatedClassExport{} -> "DeprecatedClassExport"

@@ -317,6 +321,7 @@ errorCode em = case unwrapErrorMessage em of

317321 ImplicitImport{} -> "ImplicitImport"

318322 HidingImport{} -> "HidingImport"

319323 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

324+ IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

320325

321326-- |

322327-- A stack trace for an error

@@ -424,7 +429,7 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error

424429-- TODO Other possible suggestions:

425430-- WildcardInferredType - source span not small enough

426431-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert

427−-- DeprecatedClassExport, DeprecatedClassImport, would want to replace smaller span?

432+-- DeprecatedClassExport, DeprecatedClassImport, DeprecatedOperatorSection, would want to replace smaller span?

428433errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion

429434errorSuggestion err = case err of

430435 UnusedImport{} -> emptySuggestion

@@ -798,7 +803,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

798803 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

799804 line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."

800805 renderSimpleErrorMessage (ImportHidingModule name) =

801− paras [ line $ "'hiding' imports cannot be used to hide modules."

806+ paras [ line "'hiding' imports cannot be used to hide modules."

802807 , line $ "An attempt was made to hide the import of " ++ runModuleName name

803808 ]

804809 renderSimpleErrorMessage (WildcardInferredType ty) =

@@ -812,14 +817,14 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

812817 , indent $ typeAsBox ty

813818 ]

814819 renderSimpleErrorMessage (NotExhaustivePattern bs b) =

815− paras $ [ line "A case expression could not be determined to cover all inputs."

816− , line "The following additional cases are required to cover all inputs:\n"

817− , indent $ paras $

818− [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]

819− ++ [ line "..." | not b ]

820− , line "Or alternatively, add a Partial constraint to the type of the enclosing value."

821− , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."

822− ]

820+ paras [ line "A case expression could not be determined to cover all inputs."

821+ , line "The following additional cases are required to cover all inputs:\n"

822+ , indent $ paras $

823+ [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]

824+ ++ [ line "..." | not b ]

825+ , line "Or alternatively, add a Partial constraint to the type of the enclosing value."

826+ , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."

827+ ]

823828 renderSimpleErrorMessage (OverlappingPattern bs b) =

824829 paras $ [ line "A case expression contains unreachable cases:\n"

825830 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

@@ -835,7 +840,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

835840 renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) =

836841 paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:"

837842 , indent $ paras $ map line names

838− , line $ "It could be replaced with:"

843+ , line "It could be replaced with:"

839844 , indent $ line $ showSuggestion msg ]

840845

841846 renderSimpleErrorMessage (UnusedDctorImport name) =

@@ -849,15 +854,39 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

849854 paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function."

850855 , line "Operator aliases are declared by using a fixity declaration, for example:"

851856 , indent $ line $ "infixl 9 someFunction as " ++ name

852− , line $ "Support for value-declared operators will be removed in PureScript 0.9."

857+ , line "Support for value-declared operators will be removed in PureScript 0.9."

853858 ]

854859

860+ renderSimpleErrorMessage (DeprecatedOperatorSection op val) =

861+ paras [ line "An operator section uses legacy syntax. Operator sections are now written using anonymous function syntax:"

862+ , indent $ foldr1 before $

863+ case val of

864+ Left l ->

865+ [ line "("

866+ , prettyPrintValue valueDepth l

867+ , line " "

868+ , renderOperator op

869+ , line " _)"

870+ ]

871+ Right r ->

872+ [ line "(_ "

873+ , renderOperator op

874+ , line " "

875+ , prettyPrintValue valueDepth r

876+ , line ")"

877+ ]

878+ , line "Support for legacy operator sections will be removed in PureScript 0.9."

879+ ]

880+ where

881+ renderOperator (PositionedValue _ _ ex) = renderOperator ex

882+ renderOperator (Var (Qualified _ (Op ident))) = line ident

883+ renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ]

855884 renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) =

856− paras [ line $ "Import uses the deprecated 'qualified' syntax:"

885+ paras [ line "Import uses the deprecated 'qualified' syntax:"

857886 , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName

858887 , line "Should instead use the form:"

859888 , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName

860− , line $ "The deprecated syntax will be removed in PureScript 0.9."

889+ , line "The deprecated syntax will be removed in PureScript 0.9."

861890 ]

862891

863892 renderSimpleErrorMessage (DeprecatedClassImport mn name) =

@@ -865,15 +894,15 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

865894 , indent $ line $ runProperName name

866895 , line "Should instead use the form:"

867896 , indent $ line $ "class " ++ runProperName name

868− , line $ "The deprecated syntax will be removed in PureScript 0.9."

897+ , line "The deprecated syntax will be removed in PureScript 0.9."

869898 ]

870899

871900 renderSimpleErrorMessage (DeprecatedClassExport name) =

872− paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:"

901+ paras [ line "Class export uses deprecated syntax that omits the 'class' keyword:"

873902 , indent $ line $ runProperName name

874903 , line "Should instead use the form:"

875904 , indent $ line $ "class " ++ runProperName name

876− , line $ "The deprecated syntax will be removed in PureScript 0.9."

905+ , line "The deprecated syntax will be removed in PureScript 0.9."

877906 ]

878907

879908 renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) =

@@ -915,9 +944,13 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

915944 ]

916945

917946 renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) =

918− paras $ [ line $ "Binder list length differs in case alternative:"

919− , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs

920− , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ]

947+ paras [ line "Binder list length differs in case alternative:"

948+ , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs

949+ , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "."

950+ ]

951+

952+ renderSimpleErrorMessage IncorrectAnonymousArgument =

953+ line "An anonymous function argument appears in an invalid context."

921954

922955 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

923956 renderHint (ErrorUnifyingTypes t1 t2) detail =

src/Language/PureScript/Linter.hs+1

@@ -71,6 +71,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

7171 go d | Just i <- getDeclIdent d

7272 , i `S.member` s = errorMessage (ShadowedName i)

7373 | otherwise = mempty

74+ stepE _ (OperatorSection op val) = errorMessage $ DeprecatedOperatorSection op val

7475 stepE _ _ = mempty

7576

7677 stepB :: S.Set Ident -> Binder -> MultipleErrors

src/Language/PureScript/Parser/Declarations.hs+13−19

@@ -312,18 +312,17 @@ parseArrayLiteral :: TokenParser Expr

312312parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

313313

314314parseObjectLiteral :: TokenParser Expr

315−parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)

315+parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)

316316

317−parseIdentifierAndValue :: TokenParser (String, Maybe Expr)

317+parseIdentifierAndValue :: TokenParser (String, Expr)

318318parseIdentifierAndValue =

319319 do

320320 name <- C.indented *> lname

321− b <- P.option (Just $ Var $ Qualified Nothing (Ident name)) rest

321+ b <- P.option (Var $ Qualified Nothing (Ident name)) rest

322322 return (name, b)

323323 <|> (,) <$> (C.indented *> stringLiteral) <*> rest

324324 where

325− rest = C.indented *> colon *> C.indented *> val

326− val = P.try (Just <$> parseValue) <|> (underscore *> pure Nothing)

325+ rest = C.indented *> colon *> C.indented *> parseValue

327326

328327parseAbs :: TokenParser Expr

329328parseAbs = do

@@ -373,13 +372,13 @@ parseLet = do

373372

374373parseValueAtom :: TokenParser Expr

375374parseValueAtom = P.choice

376− [ parseNumericLiteral

375+ [ parseAnonymousArgument

376+ , parseNumericLiteral

377377 , parseCharLiteral

378378 , parseStringLiteral

379379 , parseBooleanLiteral

380380 , parseArrayLiteral

381381 , P.try parseObjectLiteral

382− , P.try parseObjectGetter

383382 , parseAbs

384383 , P.try parseConstructor

385384 , P.try parseVar

@@ -389,8 +388,6 @@ parseValueAtom = P.choice

389388 , parseLet

390389 , P.try $ Parens <$> parens parseValue

391390 , parseOperatorSection

392− -- TODO: combine this with parseObjectGetter

393− , parseObjectUpdaterWildcard

394391 ]

395392

396393-- |

@@ -406,11 +403,11 @@ parseOperatorSection = parens $ left <|> right

406403 right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors)

407404 left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr

408405

409−parsePropertyUpdate :: TokenParser (String, Maybe Expr)

406+parsePropertyUpdate :: TokenParser (String, Expr)

410407parsePropertyUpdate = do

411408 name <- lname <|> stringLiteral

412409 _ <- C.indented *> equals

413− value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)

410+ value <- C.indented *> parseValue

414411 return (name, value)

415412

416413parseAccessor :: Expr -> TokenParser Expr

@@ -436,15 +433,12 @@ parseDoNotationElement = P.choice

436433 , DoNotationValue <$> parseValue

437434 ]

438435

439−parseObjectGetter :: TokenParser Expr

440−parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))

441−

442436-- | Expressions including indexers and record updates

443437indexersAndAccessors :: TokenParser Expr

444438indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom

445439 where

446440 postfixTable = [ parseAccessor

447− , P.try . parseUpdaterBody . Just

441+ , P.try . parseUpdaterBody

448442 ]

449443

450444-- |

@@ -466,11 +460,11 @@ parseValue = withSourceSpan PositionedValue

466460 ]

467461 ]

468462

469−parseUpdaterBody :: Maybe Expr -> TokenParser Expr

470−parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))

463+parseUpdaterBody :: Expr -> TokenParser Expr

464+parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))

471465

472−parseObjectUpdaterWildcard :: TokenParser Expr

473−parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing

466+parseAnonymousArgument :: TokenParser Expr

467+parseAnonymousArgument = underscore *> pure AnonymousArgument

474468

475469parseStringBinder :: TokenParser Binder

476470parseStringBinder = StringBinder <$> stringLiteral

src/Language/PureScript/Pretty/Values.hs+1−3

@@ -57,7 +57,6 @@ prettyPrintValue d (IfThenElse cond th el) =

5757 ])

5858prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop)

5959prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps

60−prettyPrintValue d (ObjectUpdater o ps) = maybe (text "_") (prettyPrintValueAtom (d - 1)) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") (prettyPrintValue (d - 1)) val) ps

6160prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

6261prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

6362prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

@@ -86,8 +85,7 @@ prettyPrintValueAtom _ (BooleanLiteral True) = text "true"

8685prettyPrintValueAtom _ (BooleanLiteral False) = text "false"

8786prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs

8887prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps

89−prettyPrintValueAtom d (ObjectConstructor ps) = prettyPrintObject (d - 1) ps

90−prettyPrintValueAtom _ (ObjectGetter prop) = text $ "_." ++ show prop

88+prettyPrintValueAtom _ AnonymousArgument = text "_"

9189prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

9290prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

9391prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"

src/Language/PureScript/Sugar/ObjectWildcards.hs+36−15

@@ -1,4 +1,5 @@

11{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE PatternGuards #-}

23{-# LANGUAGE ScopedTypeVariables #-}

45module Language.PureScript.Sugar.ObjectWildcards (

@@ -8,12 +9,11 @@ module Language.PureScript.Sugar.ObjectWildcards (

89import Prelude ()

910import Prelude.Compat

1011

11−import Control.Arrow (second)

1212import Control.Monad.Error.Class (MonadError(..))

1313import Control.Monad.Supply.Class

1414

1515import Data.List (partition)

16−import Data.Maybe (isJust, fromJust, catMaybes)

16+import Data.Maybe (catMaybes)

1717

1818import Language.PureScript.AST

1919import Language.PureScript.Errors

@@ -24,30 +24,51 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

2424 where

2525

2626 desugarDecl :: Declaration -> m Declaration

27− (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return

27+ desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d

28+ desugarDecl other = f other

29+ where

30+ (f, _, _) = everywhereOnValuesTopDownM return desugarExpr return

2831

2932 desugarExpr :: Expr -> m Expr

30− desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

31− desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps

32− desugarExpr (ObjectUpdater Nothing ps) = do

33+ desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument

34+ desugarExpr (Parens b)

35+ | b' <- stripPositionInfo b

36+ , BinaryNoParens op val u <- b'

37+ , isAnonymousArgument u = return $ OperatorSection op (Left val)

38+ | b' <- stripPositionInfo b

39+ , BinaryNoParens op u val <- b'

40+ , isAnonymousArgument u = return $ OperatorSection op (Right val)

41+ desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps

42+ desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

3343 obj <- freshIdent'

3444 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

35− desugarExpr (ObjectGetter prop) = do

45+ desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps

46+ desugarExpr (Accessor prop u) | isAnonymousArgument u = do

3647 arg <- freshIdent'

3748 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

3849 desugarExpr e = return e

3950

40− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr

51+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr

4152 wrapLambda mkVal ps =

42− let (props, args) = partition (isJust . snd) ps

53+ let (args, props) = partition (isAnonymousArgument . snd) ps

4354 in if null args

44− then return . mkVal $ second fromJust `map` props

55+ then return $ mkVal props

4556 else do

4657 (args', ps') <- unzip <$> mapM mkProp ps

4758 return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

4859

49− mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))

50− mkProp (name, Just e) = return (Nothing, (name, e))

51− mkProp (name, Nothing) = do

52− arg <- freshIdent'

53− return (Just arg, (name, Var (Qualified Nothing arg)))

60+ stripPositionInfo :: Expr -> Expr

61+ stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e

62+ stripPositionInfo e = e

63+

64+ isAnonymousArgument :: Expr -> Bool

65+ isAnonymousArgument AnonymousArgument = True

66+ isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e

67+ isAnonymousArgument _ = False

68+

69+ mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr))

70+ mkProp (name, e)

71+ | isAnonymousArgument e = do

72+ arg <- freshIdent'

73+ return (Just arg, (name, Var (Qualified Nothing arg)))

74+ | otherwise = return (Nothing, (name, e))