summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2015-02-09 03:23:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-02-09 03:23:00 (GMT)
commite4014132795a96611ae110b7a2dce5b35a7d5463 (patch)
treec86f600e89e2a01d28d1aac7528fefbd8c01f7d2
parent7a93ea6e810fc4fd4061d6b3afaeed1e4a79162f (diff)
version 0.6.60.6.6
-rw-r--r--examples/passing/ExtendedInfixOperators.purs20
-rw-r--r--examples/passing/ObjectGetter.purs8
-rw-r--r--examples/passing/ObjectUpdater.purs3
-rw-r--r--psc-docs/Main.hs4
-rw-r--r--psc/Main.hs4
-rw-r--r--purescript.cabal4
-rw-r--r--src/Language/PureScript/AST/Declarations.hs6
-rw-r--r--src/Language/PureScript/AST/Traversals.hs49
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs1
-rw-r--r--src/Language/PureScript/Parser/Common.hs6
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs27
-rw-r--r--src/Language/PureScript/Pretty/Values.hs7
-rw-r--r--src/Language/PureScript/Sugar/Names.hs4
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs5
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs20
15 files changed, 99 insertions, 69 deletions
diff --git a/examples/passing/ExtendedInfixOperators.purs b/examples/passing/ExtendedInfixOperators.purs
new file mode 100644
index 0000000..b6ab020
--- /dev/null
+++ b/examples/passing/ExtendedInfixOperators.purs
@@ -0,0 +1,20 @@
+module Main where
+
+zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
+zipWith _ [] _ = []
+zipWith _ _ [] = []
+zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys
+
+test1 = [1, 2, 3] `zipWith (+)` [4, 5, 6]
+
+comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering
+comparing f = compare `Data.Function.on` f
+
+sum [] = 0
+sum (x:xs) = x + sum xs
+
+test2 = [1, 2, 3] `comparing sum` [4, 5, 6]
+
+main = do
+ Debug.Trace.print test1
+ Debug.Trace.print test2
diff --git a/examples/passing/ObjectGetter.purs b/examples/passing/ObjectGetter.purs
index 6004065..b786ae0 100644
--- a/examples/passing/ObjectGetter.purs
+++ b/examples/passing/ObjectGetter.purs
@@ -1,11 +1,11 @@
module Main where
-getX = (.x)
+getX = _.x
point = { x: 1, y: 0 }
main = do
Debug.Trace.print $ getX point
- Debug.Trace.trace $ (." 123 string Prop Name ") { " 123 string Prop Name ": "OK" }
- Debug.Trace.trace $ ((.x) >>> (.y)) { x: { y: "Nested" } }
- Debug.Trace.trace $ (.value) { value: "Done!" }
+ Debug.Trace.trace $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" }
+ Debug.Trace.trace $ (_.x >>> _.y) { x: { y: "Nested" } }
+ Debug.Trace.trace $ _.value { value: "Done!" }
diff --git a/examples/passing/ObjectUpdater.purs b/examples/passing/ObjectUpdater.purs
index 53f8df6..23f48b4 100644
--- a/examples/passing/ObjectUpdater.purs
+++ b/examples/passing/ObjectUpdater.purs
@@ -30,3 +30,6 @@ main = do
print $ point'.x === 100
print $ point'.y === 10
+
+ let record2 = (_ { x = _ }) { x: 0 } 10
+ print $ record2.x === 10
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index 0aeb9bd..8edb75f 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -28,7 +28,7 @@ import Options.Applicative
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import System.Exit (exitSuccess, exitFailure)
-import System.IO (hPutStr, stderr)
+import System.IO (hPutStrLn, stderr)
data PSCDocsOptions = PSCDocsOptions
@@ -42,7 +42,7 @@ docgen (PSCDocsOptions showHierarchy input) = do
e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
case e of
Left err -> do
- hPutStr stderr $ show err
+ hPutStrLn stderr $ show err
exitFailure
Right ms -> do
putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)
diff --git a/psc/Main.hs b/psc/Main.hs
index 0e42118..df1db1f 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -26,7 +26,7 @@ import Options.Applicative as Opts
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.Exit (exitSuccess, exitFailure)
-import System.IO (hPutStr, hPutStrLn, stderr)
+import System.IO (hPutStrLn, stderr)
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
@@ -58,7 +58,7 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do
modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)
case modules of
Left err -> do
- hPutStr stderr $ show err
+ hPutStrLn stderr $ show err
exitFailure
Right ms -> do
case P.compile opts (map snd ms) prefix of
diff --git a/purescript.cabal b/purescript.cabal
index a54cf15..cb130d5 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.6.5
+version: 0.6.6
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -159,7 +159,7 @@ executable psc-docs
other-modules:
ghc-options: -Wall -fno-warn-warnings-deprecations -O2
-executable hierarchy
+executable psc-hierarchy
build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,
process -any, mtl -any, parsec -any, filepath -any, directory -any
main-is: Main.hs
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index aefabcb..9ed3f88 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -305,7 +305,7 @@ data Expr
-- Binary operator application. During the rebracketing phase of desugaring, this data constructor
-- will be removed.
--
- | BinaryNoParens (Qualified Ident) Expr Expr
+ | BinaryNoParens Expr Expr Expr
-- |
-- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
-- will be removed.
@@ -315,7 +315,7 @@ data Expr
-- Operator section. This will be removed during desugaring and replaced with a partially applied
-- operator or lambda to flip the arguments.
--
- | OperatorSection (Qualified Ident) (Either Expr Expr)
+ | OperatorSection Expr (Either Expr Expr)
-- |
-- An array literal
--
@@ -346,7 +346,7 @@ data Expr
-- Partial record updater. This will be removed during desugaring and
-- expanded into a lambda that returns an object update.
--
- | ObjectUpdater Expr [(String, Maybe Expr)]
+ | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]
-- |
-- Function introduction
--
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 511710e..e501b23 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -43,17 +43,17 @@ everywhereOnValues f g h = (f', g', h')
g' :: Expr -> Expr
g' (UnaryMinus v) = g (UnaryMinus (g' v))
- g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))
+ g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))
g' (Parens v) = g (Parens (g' v))
- g' (OperatorSection op (Left v)) = g (OperatorSection op (Left $ g' v))
- g' (OperatorSection op (Right v)) = g (OperatorSection op (Right $ g' v))
+ g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))
+ g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))
g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))
g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
g' (Accessor prop v) = g (Accessor prop (g' v))
g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
- g' (ObjectUpdater obj vs) = g (ObjectUpdater (g' obj) (map (second (fmap g')) vs))
+ g' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (fmap g')) vs))
g' (Abs name v) = g (Abs name (g' v))
g' (App v1 v2) = g (App (g' v1) (g' v2))
g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
@@ -85,7 +85,6 @@ everywhereOnValues f g h = (f', g', h')
handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
-
everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
(Declaration -> m Declaration) ->
(Expr -> m Expr) ->
@@ -102,17 +101,17 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
f' other = f other
g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
- g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')
+ g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
g' (Parens v) = Parens <$> (g v >>= g')
- g' (OperatorSection op (Left v)) = OperatorSection op . Left <$> (g v >>= g')
- g' (OperatorSection op (Right v)) = OperatorSection op . Right <$> (g v >>= g')
+ g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))
+ g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))
g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs
g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs
g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs
g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs
- g' (ObjectUpdater obj vs) = ObjectUpdater <$> (g obj >>= g') <*> mapM (sndM $ maybeM (g' <=< g)) vs
+ g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> mapM (sndM $ maybeM (g' <=< g)) vs
g' (Abs name v) = Abs name <$> (g v >>= g')
g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
@@ -155,17 +154,17 @@ everywhereOnValuesM f g h = (f', g', h')
f' other = f other
g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
- g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> g' v1 <*> g' v2) >>= g
+ g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
g' (Parens v) = (Parens <$> g' v) >>= g
- g' (OperatorSection op (Left v)) = (OperatorSection op . Left <$> g' v) >>= g
- g' (OperatorSection op (Right v)) = (OperatorSection op . Right <$> g' v) >>= g
+ g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g
+ g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g
g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g
g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g
g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g
g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g
- g' (ObjectUpdater obj vs) = (ObjectUpdater <$> g' obj <*> mapM (sndM $ maybeM g') vs) >>= g
+ g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> mapM (sndM $ maybeM g') vs) >>= g
g' (Abs name v) = (Abs name <$> g' v) >>= g
g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
@@ -211,17 +210,17 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
f' d = f d
g' v@(UnaryMinus v1) = g v <> g' v1
- g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2
+ g' v@(BinaryNoParens op v1 v2) = g v <> g op <> g' v1 <> g' v2
g' v@(Parens v1) = g v <> g' v1
- g' v@(OperatorSection _ (Left v1)) = g v <> g' v1
- g' v@(OperatorSection _ (Right v1)) = g v <> g' v1
+ g' v@(OperatorSection op (Left v1)) = g v <> g op <> g' v1
+ g' v@(OperatorSection op (Right v1)) = g v <> g op <> g' v1
g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))
g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
g' v@(Accessor _ v1) = g v <> g' v1
g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
- g' v@(ObjectUpdater obj vs) = foldl (<>) (g v <> g' obj) (map g' (mapMaybe snd vs))
+ g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs))
g' v@(Abs _ v1) = g v <> g' v1
g' v@(App v1 v2) = g v <> g' v1 <> g' v2
g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3
@@ -278,17 +277,17 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
g'' s v = let (s', r) = g s v in r <> g' s' v
g' s (UnaryMinus v1) = g'' s v1
- g' s (BinaryNoParens _ v1 v2) = g'' s v1 <> g'' s v2
+ g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
g' s (Parens v1) = g'' s v1
- g' s (OperatorSection _ (Left v)) = g'' s v
- g' s (OperatorSection _ (Right v)) = g'' s v
+ g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
+ g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))
g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
g' s (Accessor _ v1) = g'' s v1
g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
- g' s (ObjectUpdater obj vs) = foldl (<>) (g'' s obj) (map (g'' s) (mapMaybe snd vs))
+ g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs))
g' s (Abs _ v1) = g'' s v1
g' s (App v1 v2) = g'' s v1 <> g'' s v2
g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
@@ -348,17 +347,17 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
g'' s = uncurry g' <=< g s
g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
- g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2
+ g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
g' s (Parens v) = Parens <$> g'' s v
- g' s (OperatorSection op (Left v)) = OperatorSection op . Left <$> g'' s v
- g' s (OperatorSection op (Right v)) = OperatorSection op . Right <$> g'' s v
+ g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)
+ g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)
g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs
g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs
g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs
g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
g' s (Accessor prop v) = Accessor prop <$> g'' s v
g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs
- g' s (ObjectUpdater obj vs) = ObjectUpdater <$> g'' s obj <*> mapM (sndM $ maybeM (g'' s)) vs
+ g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> mapM (sndM $ maybeM (g'' s)) vs
g' s (Abs name v) = Abs name <$> g'' s v
g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index b358b56..4a9cb20 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -54,7 +54,6 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (
forValues :: Expr -> [ModuleName]
forValues (Var (Qualified (Just mn) _)) = [mn]
- forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]
forValues (Constructor (Qualified (Just mn) _)) = [mn]
forValues (TypedValue _ _ ty) = forTypes ty
forValues _ = []
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index ed9b750..973daf2 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -89,12 +89,6 @@ buildPostfixParser fs first = do
Just a' -> go a'
-- |
--- Parse an identifier in backticks or an operator
---
-parseIdentInfix :: TokenParser (Qualified Ident)
-parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> symbol))
-
--- |
-- Mark the current indentation level
--
mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index ef9ca80..4518aa0 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -41,6 +41,7 @@ import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
import Language.PureScript.Parser.Lexer
+import Language.PureScript.Names
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
@@ -354,13 +355,21 @@ parseValueAtom = P.choice
, parseDo
, parseLet
, P.try $ Parens <$> parens parseValue
- , parseOperatorSection ]
+ , parseOperatorSection
+ , P.try parseObjectUpdaterWildcard ]
+
+-- |
+-- Parse an expression in backticks or an operator
+--
+parseInfixExpr :: TokenParser Expr
+parseInfixExpr = P.between tick tick parseValue
+ <|> Var <$> parseQualified (Op <$> symbol)
parseOperatorSection :: TokenParser Expr
parseOperatorSection = parens $ left <|> right
where
- right = OperatorSection <$> parseIdentInfix <* indented <*> (Right <$> parseValueAtom)
- left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseIdentInfix
+ right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom)
+ left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr
parsePropertyUpdate :: TokenParser (String, Maybe Expr)
parsePropertyUpdate = do
@@ -392,7 +401,7 @@ parseDoNotationElement = P.choice
, P.try (DoNotationValue <$> parseValue) ]
parseObjectGetter :: TokenParser Expr
-parseObjectGetter = ObjectGetter <$> parens (dot *> C.indented *> (lname <|> stringLiteral))
+parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))
-- |
-- Parse a value
@@ -405,17 +414,23 @@ parseValue = withSourceSpan PositionedValue
where
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
postfixTable1 = [ parseAccessor
- , \v -> P.try $ flip ObjectUpdater <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
+ , P.try . parseUpdaterBody . Just ]
postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
, \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v
]
operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)
]
- , [ P.Infix (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
+ , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
return (BinaryNoParens ident)) P.AssocRight
]
]
+parseUpdaterBody :: Maybe Expr -> TokenParser Expr
+parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
+
+parseObjectUpdaterWildcard :: TokenParser Expr
+parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing
+
parseStringBinder :: TokenParser Binder
parseStringBinder = StringBinder <$> stringLiteral
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 8cf23e2..568c26e 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -27,6 +27,7 @@ import Control.Monad.State
import Control.Applicative
import Language.PureScript.AST
+import Language.PureScript.Names
import Language.PureScript.Pretty.Common
import Language.PureScript.Pretty.Types (prettyPrintType)
@@ -73,8 +74,8 @@ literals = mkPattern' match
, withIndent $ prettyPrintMany prettyPrintDoNotationElement els
, currentIndent
]
- match (OperatorSection op (Right val)) = return $ "(" ++ show op ++ " " ++ prettyPrintValue val ++ ")"
- match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ show op ++ ")"
+ match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"
+ match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"
match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"
match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
match (TypedValue _ val _) = prettyPrintValue' val
@@ -151,7 +152,7 @@ objectUpdate :: Pattern PrinterState Expr ([String], Expr)
objectUpdate = mkPattern match
where
match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
- match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, o)
+ match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, fromMaybe (Var (Qualified Nothing $ Ident "_")) o)
match _ = Nothing
app :: Pattern PrinterState Expr (String, Expr)
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index ea79d11..31eb7d7 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -240,10 +240,6 @@ renameInModule imports exports (Module mn decls exps) =
(,) (pos, bound) <$> (Var <$> updateValueName name' pos)
updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
(,) (pos, bound) <$> (Var <$> updateValueName name' pos)
- updateValue (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =
- (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
- updateValue (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
- (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)
updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
updateValue s v = return (s, v)
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
index 00d6872..625d4aa 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -36,7 +36,10 @@ desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl d
desugarExpr :: Expr -> SupplyT (Either ErrorStack) Expr
desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
- desugarExpr (ObjectUpdater obj ps) = wrapLambda (ObjectUpdate obj) ps
+ desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
+ desugarExpr (ObjectUpdater Nothing ps) = do
+ obj <- Ident <$> freshName
+ Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
desugarExpr (ObjectGetter prop) = do
arg <- Ident <$> freshName
return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 66b57f8..2120d8b 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -105,7 +105,7 @@ customOperatorTable fixities =
in
map (map (\(name, f, _, a) -> (name, f, a))) groups
-type Chain = [Either Expr (Qualified Ident)]
+type Chain = [Either Expr Expr]
matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr
matchOperators ops = parseChains
@@ -114,11 +114,11 @@ matchOperators ops = parseChains
parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
parseChains other = return other
extendChain :: Expr -> Chain
- extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
+ extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
extendChain other = [Left other]
bracketChain :: Chain -> Either ErrorStack Expr
bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
- opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]
+ opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]
: map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
@@ -136,14 +136,14 @@ parseValue = token (either Just (const Nothing)) P.<?> "expression"
parseOp :: P.Parsec Chain () (Qualified Ident)
parseOp = token (either (const Nothing) fromOp) P.<?> "operator"
where
- fromOp q@(Qualified _ (Op _)) = Just q
+ fromOp (Var q@(Qualified _ (Op _))) = Just q
fromOp _ = Nothing
-parseTicks :: P.Parsec Chain () (Qualified Ident)
-parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"
+parseTicks :: P.Parsec Chain () Expr
+parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"
where
- fromOp q@(Qualified _ (Ident _)) = Just q
- fromOp _ = Nothing
+ fromOther (Var (Qualified _ (Op _))) = Nothing
+ fromOther v = Just v
matchOp :: Qualified Ident -> P.Parsec Chain () ()
matchOp op = do
@@ -158,8 +158,8 @@ desugarOperatorSections (Module mn ds exts) = Module mn <$> mapM goDecl ds <*> p
(goDecl, _, _) = everywhereOnValuesM return goExpr return
goExpr :: Expr -> SupplyT (Either ErrorStack) Expr
- goExpr (OperatorSection op (Left val)) = return $ App (Var op) val
+ goExpr (OperatorSection op (Left val)) = return $ App op val
goExpr (OperatorSection op (Right val)) = do
arg <- Ident <$> freshName
- return $ Abs (Left arg) $ App (App (Var op) (Var (Qualified Nothing arg))) val
+ return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
goExpr other = return other