purescript 0.6.5 → 0.6.6
raw patch · 15 files changed
+99/−69 lines, 15 filesnew-component:exe:psc-hierarchyPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Language.PureScript.Parser.Common: parseIdentInfix :: TokenParser (Qualified Ident)
- Language.PureScript.AST.Declarations: BinaryNoParens :: (Qualified Ident) -> Expr -> Expr -> Expr
+ Language.PureScript.AST.Declarations: BinaryNoParens :: Expr -> Expr -> Expr -> Expr
- Language.PureScript.AST.Declarations: ObjectUpdater :: Expr -> [(String, Maybe Expr)] -> Expr
+ Language.PureScript.AST.Declarations: ObjectUpdater :: (Maybe Expr) -> [(String, Maybe Expr)] -> Expr
- Language.PureScript.AST.Declarations: OperatorSection :: (Qualified Ident) -> (Either Expr Expr) -> Expr
+ Language.PureScript.AST.Declarations: OperatorSection :: Expr -> (Either Expr Expr) -> Expr
Files
- examples/passing/ExtendedInfixOperators.purs +20/−0
- examples/passing/ObjectGetter.purs +4/−4
- examples/passing/ObjectUpdater.purs +3/−0
- psc-docs/Main.hs +2/−2
- psc/Main.hs +2/−2
- purescript.cabal +2/−2
- src/Language/PureScript/AST/Declarations.hs +3/−3
- src/Language/PureScript/AST/Traversals.hs +24/−25
- src/Language/PureScript/ModuleDependencies.hs +0/−1
- src/Language/PureScript/Parser/Common.hs +0/−6
- src/Language/PureScript/Parser/Declarations.hs +21/−6
- src/Language/PureScript/Pretty/Values.hs +4/−3
- src/Language/PureScript/Sugar/Names.hs +0/−4
- src/Language/PureScript/Sugar/ObjectWildcards.hs +4/−1
- src/Language/PureScript/Sugar/Operators.hs +10/−10
+ examples/passing/ExtendedInfixOperators.purs view
@@ -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
examples/passing/ObjectGetter.purs view
@@ -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!" }
examples/passing/ObjectUpdater.purs view
@@ -30,3 +30,6 @@ print $ point'.x === 100 print $ point'.y === 10++ let record2 = (_ { x = _ }) { x: 0 } 10+ print $ record2.x === 10
psc-docs/Main.hs view
@@ -28,7 +28,7 @@ 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 @@ 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)
psc/Main.hs view
@@ -26,7 +26,7 @@ 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 @@ 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
purescript.cabal view
@@ -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 @@ 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
src/Language/PureScript/AST/Declarations.hs view
@@ -305,7 +305,7 @@ -- 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 @@ -- 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 @@ -- 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 --
src/Language/PureScript/AST/Traversals.hs view
@@ -43,17 +43,17 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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
src/Language/PureScript/ModuleDependencies.hs view
@@ -54,7 +54,6 @@ 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 _ = []
src/Language/PureScript/Parser/Common.hs view
@@ -89,12 +89,6 @@ 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
src/Language/PureScript/Parser/Declarations.hs view
@@ -41,6 +41,7 @@ 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 @@ , 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 @@ , 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,16 +414,22 @@ 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
src/Language/PureScript/Pretty/Values.hs view
@@ -27,6 +27,7 @@ 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 @@ , 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 = 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)
src/Language/PureScript/Sugar/Names.hs view
@@ -240,10 +240,6 @@ (,) (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)
src/Language/PureScript/Sugar/ObjectWildcards.hs view
@@ -36,7 +36,10 @@ 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)))
src/Language/PureScript/Sugar/Operators.hs view
@@ -105,7 +105,7 @@ 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 @@ 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 @@ 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 @@ (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