summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2015-02-08 05:08:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-02-08 05:08:00 (GMT)
commit7a93ea6e810fc4fd4061d6b3afaeed1e4a79162f (patch)
treee7a7593d9150dee2e79da4c86740ddfeeea37030
parent20ed2828110ec7ebc926a7ca29ea4af8b2ef2eb4 (diff)
version 0.6.50.6.5
-rw-r--r--examples/passing/ObjectGetter.purs11
-rw-r--r--examples/passing/ObjectUpdater.purs32
-rw-r--r--examples/passing/ObjectWildcards.purs31
-rw-r--r--examples/passing/OperatorSections.purs21
-rw-r--r--examples/passing/RowSynonyms.purs46
-rw-r--r--psc-make/Main.hs4
-rw-r--r--purescript.cabal3
-rw-r--r--src/Language/PureScript/AST/Declarations.hs20
-rw-r--r--src/Language/PureScript/AST/Traversals.hs27
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs29
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs7
-rw-r--r--src/Language/PureScript/Parser/Types.hs2
-rw-r--r--src/Language/PureScript/Pretty/Values.hs62
-rw-r--r--src/Language/PureScript/Sugar.hs29
-rw-r--r--src/Language/PureScript/Sugar/Names.hs47
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs58
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs19
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs4
18 files changed, 390 insertions, 62 deletions
diff --git a/examples/passing/ObjectGetter.purs b/examples/passing/ObjectGetter.purs
new file mode 100644
index 0000000..6004065
--- /dev/null
+++ b/examples/passing/ObjectGetter.purs
@@ -0,0 +1,11 @@
+module Main where
+
+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!" }
diff --git a/examples/passing/ObjectUpdater.purs b/examples/passing/ObjectUpdater.purs
new file mode 100644
index 0000000..53f8df6
--- /dev/null
+++ b/examples/passing/ObjectUpdater.purs
@@ -0,0 +1,32 @@
+module Main where
+
+import Control.Monad.Eff
+import Debug.Trace
+
+foreign import eqeqeq
+ """
+ function eqeqeq(x) {
+ return function (y) {
+ if (x == y) return x;
+ throw new Error("Unexpected result: " + x + " /== " + y);
+ };
+ };
+ """ :: forall a. a -> a -> a
+
+(===) = eqeqeq
+infixl 4 ===
+
+getValue :: forall e. Eff (| e) Boolean
+getValue = return true
+
+main = do
+ let record = { value: false }
+ record' <- record { value = _ } <$> getValue
+ print $ record'.value === true
+
+ let point = { x: 1, y: 1 }
+ x = 10
+ point' = (point { x = _, y = x }) 100
+
+ print $ point'.x === 100
+ print $ point'.y === 10
diff --git a/examples/passing/ObjectWildcards.purs b/examples/passing/ObjectWildcards.purs
new file mode 100644
index 0000000..0bf221a
--- /dev/null
+++ b/examples/passing/ObjectWildcards.purs
@@ -0,0 +1,31 @@
+module Main where
+
+import Control.Monad.Eff
+import Debug.Trace
+
+mkRecord = { foo: _, bar: _, baz: "baz" }
+
+getValue :: forall e. Eff (| e) Boolean
+getValue = return true
+
+foreign import eqeqeq
+ """
+ function eqeqeq(x) {
+ return function (y) {
+ if (x == y) return x;
+ throw new Error("Unexpected result: " + x + " /== " + y);
+ };
+ };
+ """ :: forall a. a -> a -> a
+
+(===) = eqeqeq
+infixl 4 ===
+
+main = do
+ obj <- { value: _ } <$> getValue
+ print obj.value
+ let x = 1
+ point <- { x: _, y: x } <$> return 2
+ print $ point.x === 2
+ print $ point.y === 1
+ trace (mkRecord 1 "Done!").bar
diff --git a/examples/passing/OperatorSections.purs b/examples/passing/OperatorSections.purs
new file mode 100644
index 0000000..16a8f9b
--- /dev/null
+++ b/examples/passing/OperatorSections.purs
@@ -0,0 +1,21 @@
+module Main where
+
+foreign import eqeqeq
+ """
+ function eqeqeq(x) {
+ return function (y) {
+ if (x == y) return x;
+ throw new Error("Unexpected result: " + x + " /== " + y);
+ };
+ };
+ """ :: forall a. a -> a -> a
+
+(===) = eqeqeq
+infixl 4 ===
+
+main = do
+ Debug.Trace.print $ (/ 2) 4 === 2
+ Debug.Trace.print $ (2 /) 4 === 0.5
+ Debug.Trace.print $ (`const` 1) 2 === 2
+ Debug.Trace.print $ (1 `const`) 2 === 1
+ Debug.Trace.trace "Done!"
diff --git a/examples/passing/RowSynonyms.purs b/examples/passing/RowSynonyms.purs
new file mode 100644
index 0000000..8b47d73
--- /dev/null
+++ b/examples/passing/RowSynonyms.purs
@@ -0,0 +1,46 @@
+module Main where
+
+import Control.Monad.Eff
+import Control.Monad.ST
+
+type State bindings =
+ {
+ bindings :: {addition :: Number | bindings},
+ other :: String
+ }
+
+type MyBindings = (test :: Number)
+
+data Shadow bindings = Shadow String
+
+shadows :: Shadow (Object MyBindings)
+shadows = Shadow "uhh"
+
+main :: Eff () Unit
+main = withIt
+ shadows
+ \ bindings -> do
+ let state =
+ {
+ bindings : bindings,
+ other : "Test"
+ }
+ runST do
+ stRef <- newSTRef state
+ handleKeyD stRef
+ return unit
+
+
+withIt :: forall bindings eff a. Shadow (Object bindings) ->
+ ({addition :: Number | bindings} -> Eff eff a) -> Eff eff a
+withIt (Shadow str) success = do
+ b <- withBindings
+ success (b{addition = 1})
+
+foreign import withBindings
+"""
+ function withBindings() {}
+""" :: forall eff bindings. Eff eff bindings
+
+handleKeyD :: forall h eff. STRef h (State MyBindings) -> Eff (st :: ST h | eff) Unit
+handleKeyD state = return unit
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index 3912e8e..fcad3fb 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -127,13 +127,13 @@ noMagicDo = switch $
noOpts :: Parser Bool
noOpts = switch $
- long "verbose-errors"
+ long "no-opts"
<> help "Skip the optimization phase."
verboseErrors :: Parser Bool
verboseErrors = switch $
short 'v'
- <> long "no-opts"
+ <> long "verbose-errors"
<> help "Display verbose error messages"
noPrefix :: Parser Bool
diff --git a/purescript.cabal b/purescript.cabal
index 3ae0e23..a54cf15 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.6.4.1
+version: 0.6.5
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -93,6 +93,7 @@ library
Language.PureScript.Sugar.CaseDeclarations
Language.PureScript.Sugar.DoNotation
Language.PureScript.Sugar.Names
+ Language.PureScript.Sugar.ObjectWildcards
Language.PureScript.Sugar.Operators
Language.PureScript.Sugar.TypeClasses
Language.PureScript.Sugar.TypeDeclarations
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index f02f22d..aefabcb 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -312,6 +312,11 @@ data Expr
--
| Parens 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)
+ -- |
-- An array literal
--
| ArrayLiteral [Expr]
@@ -320,6 +325,16 @@ data Expr
--
| ObjectLiteral [(String, Expr)]
-- |
+ -- An object constructor (object literal with underscores). This will be removed during
+ -- desugaring and expanded into a lambda that returns an object literal.
+ --
+ | ObjectConstructor [(String, Maybe Expr)]
+ -- |
+ -- An object property getter (e.g. `_.x`). This will be removed during
+ -- desugaring and expanded into a lambda that reads a property from an object.
+ --
+ | ObjectGetter String
+ -- |
-- An record property accessor expression
--
| Accessor String Expr
@@ -328,6 +343,11 @@ data Expr
--
| ObjectUpdate Expr [(String, 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)]
+ -- |
-- Function introduction
--
| Abs (Either Ident Binder) Expr
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 9e81e3d..511710e 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -15,10 +15,11 @@
module Language.PureScript.AST.Traversals where
import Data.Monoid (Monoid(..), mconcat)
+import Data.Maybe (mapMaybe)
import Control.Applicative
import Control.Monad
-import Control.Arrow ((***), (+++))
+import Control.Arrow ((***), (+++), second)
import Language.PureScript.AST.Binders
import Language.PureScript.AST.Declarations
@@ -44,11 +45,15 @@ everywhereOnValues f g h = (f', g', h')
g' (UnaryMinus v) = g (UnaryMinus (g' v))
g' (BinaryNoParens op v1 v2) = g (BinaryNoParens 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' (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' (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))
@@ -99,11 +104,15 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (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' (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' (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')
@@ -148,11 +157,15 @@ everywhereOnValuesM f g h = (f', g', h')
g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
g' (BinaryNoParens op v1 v2) = (BinaryNoParens 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' (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' (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
@@ -200,11 +213,15 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
g' v@(UnaryMinus v1) = g v <> g' v1
g' v@(BinaryNoParens _ v1 v2) = g v <> 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@(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@(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
@@ -263,11 +280,15 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
g' s (UnaryMinus v1) = g'' s v1
g' s (BinaryNoParens _ v1 v2) = 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 (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 (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
@@ -329,11 +350,15 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
g' s (BinaryNoParens op v1 v2) = BinaryNoParens 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 (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 (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/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 3226be1..ef9ca80 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -285,11 +285,13 @@ parseArrayLiteral :: TokenParser Expr
parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
parseObjectLiteral :: TokenParser Expr
-parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)
+parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)
-parseIdentifierAndValue :: TokenParser (String, Expr)
+parseIdentifierAndValue :: TokenParser (String, Maybe Expr)
parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)
- <*> (C.indented *> parseValue)
+ <*> (C.indented *> val)
+ where
+ val = (Just <$> parseValue) <|> (underscore *> pure Nothing)
parseAbs :: TokenParser Expr
parseAbs = do
@@ -343,6 +345,7 @@ parseValueAtom = P.choice
, P.try parseBooleanLiteral
, parseArrayLiteral
, P.try parseObjectLiteral
+ , P.try parseObjectGetter
, parseAbs
, P.try parseConstructor
, P.try parseVar
@@ -350,13 +353,20 @@ parseValueAtom = P.choice
, parseIfThenElse
, parseDo
, parseLet
- , Parens <$> parens parseValue ]
+ , P.try $ Parens <$> parens parseValue
+ , parseOperatorSection ]
+
+parseOperatorSection :: TokenParser Expr
+parseOperatorSection = parens $ left <|> right
+ where
+ right = OperatorSection <$> parseIdentInfix <* indented <*> (Right <$> parseValueAtom)
+ left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseIdentInfix
-parsePropertyUpdate :: TokenParser (String, Expr)
+parsePropertyUpdate :: TokenParser (String, Maybe Expr)
parsePropertyUpdate = do
name <- lname <|> stringLiteral
_ <- C.indented *> equals
- value <- C.indented *> parseValue
+ value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)
return (name, value)
parseAccessor :: Expr -> TokenParser Expr
@@ -381,6 +391,9 @@ parseDoNotationElement = P.choice
, parseDoNotationLet
, P.try (DoNotationValue <$> parseValue) ]
+parseObjectGetter :: TokenParser Expr
+parseObjectGetter = ObjectGetter <$> parens (dot *> C.indented *> (lname <|> stringLiteral))
+
-- |
-- Parse a value
--
@@ -392,7 +405,7 @@ parseValue = withSourceSpan PositionedValue
where
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
postfixTable1 = [ parseAccessor
- , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
+ , \v -> P.try $ flip ObjectUpdater <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
, \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v
]
@@ -437,7 +450,7 @@ parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)
<*> (C.indented *> parseBinder)
parseNullBinder :: TokenParser Binder
-parseNullBinder = reserved "_" *> return NullBinder
+parseNullBinder = underscore *> return NullBinder
parseIdentifierAndBinder :: TokenParser (String, Binder)
parseIdentifierAndBinder = do
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index 1585da7..03d771e 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -47,6 +47,7 @@ module Language.PureScript.Parser.Lexer
, comma
, semi
, at
+ , underscore
, semiSep
, semiSep1
, commaSep
@@ -105,6 +106,7 @@ data Token
| Comma
| Semi
| At
+ | Underscore
| LName String
| UName String
| Qualifier String
@@ -133,6 +135,7 @@ prettyPrintToken Dot = "."
prettyPrintToken Comma = ","
prettyPrintToken Semi = ";"
prettyPrintToken At = "@"
+prettyPrintToken Underscore = "_"
prettyPrintToken (Indent n) = "indentation at level " ++ show n
prettyPrintToken (LName s) = show s
prettyPrintToken (UName s) = show s
@@ -196,6 +199,7 @@ parseToken = P.choice
, P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot
, P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi
, P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At
+ , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore
, LName <$> parseLName
, do uName <- parseUName
(guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)
@@ -349,6 +353,9 @@ semi = match Semi
at :: TokenParser ()
at = match At
+underscore :: TokenParser ()
+underscore = match Underscore
+
-- |
-- Parse zero or more values separated by semicolons
--
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 06e5b85..3135be1 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -45,7 +45,7 @@ parseObject :: TokenParser Type
parseObject = braces $ TypeApp tyObject <$> parseRow
parseTypeWildcard :: TokenParser Type
-parseTypeWildcard = reserved "_" >> return TypeWildcard
+parseTypeWildcard = underscore >> return TypeWildcard
parseTypeVariable :: TokenParser Type
parseTypeVariable = do
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 9b6faed..8cf23e2 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -21,7 +21,7 @@ module Language.PureScript.Pretty.Values (
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
-import Control.Arrow ((<+>), runKleisli)
+import Control.Arrow ((<+>), runKleisli, second)
import Control.PatternArrows
import Control.Monad.State
import Control.Applicative
@@ -38,33 +38,28 @@ literals = mkPattern' match
match (StringLiteral s) = return $ show s
match (BooleanLiteral True) = return "true"
match (BooleanLiteral False) = return "false"
- match (ArrayLiteral xs) = fmap concat $ sequence
+ match (ArrayLiteral xs) = concat <$> sequence
[ return "[ "
, withIndent $ prettyPrintMany prettyPrintValue' xs
, return " ]"
]
- match (ObjectLiteral []) = return "{}"
- match (ObjectLiteral ps) = fmap concat $ sequence
- [ return "{\n"
- , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
- , return "\n"
- , currentIndent
- , return "}"
- ]
- match (TypeClassDictionaryConstructorApp className ps) = fmap concat $ sequence
- [ return ((show className) ++ "(\n")
+ match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps
+ match (ObjectConstructor ps) = prettyPrintObject' ps
+ match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"
+ match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence
+ [ return (show className ++ "(\n")
, match ps
, return ")"
]
match (Constructor name) = return $ show name
- match (Case values binders) = fmap concat $ sequence
+ match (Case values binders) = concat <$> sequence
[ return "case "
, unwords <$> forM values prettyPrintValue'
, return " of\n"
, withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
, currentIndent
]
- match (Let ds val) = fmap concat $ sequence
+ match (Let ds val) = concat <$> sequence
[ return "let\n"
, withIndent $ prettyPrintMany prettyPrintDeclaration ds
, return "\n"
@@ -73,11 +68,13 @@ literals = mkPattern' match
, prettyPrintValue' val
]
match (Var ident) = return $ show ident
- match (Do els) = fmap concat $ sequence
+ match (Do els) = concat <$> sequence
[ return "do "
, 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 (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"
match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
match (TypedValue _ val _) = prettyPrintValue' val
@@ -86,7 +83,7 @@ literals = mkPattern' match
prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
-prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $ sequence
+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence
[ return $ show ident ++ " = "
, prettyPrintValue' val
]
@@ -95,7 +92,7 @@ prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
prettyPrintCaseAlternative (CaseAlternative binders result) =
- fmap concat $ sequence
+ concat <$> sequence
[ intercalate ", " <$> forM binders prettyPrintBinder'
, prettyPrintResult result
]
@@ -104,7 +101,7 @@ prettyPrintCaseAlternative (CaseAlternative binders result) =
prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v
prettyPrintGuardedValue (grd, val) =
- fmap concat $ sequence
+ concat <$> sequence
[ return "| "
, prettyPrintValue' grd
, return " -> "
@@ -116,18 +113,28 @@ prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe S
prettyPrintDoNotationElement (DoNotationValue val) =
prettyPrintValue' val
prettyPrintDoNotationElement (DoNotationBind binder val) =
- fmap concat $ sequence
+ concat <$> sequence
[ prettyPrintBinder' binder
, return " <- "
, prettyPrintValue' val
]
prettyPrintDoNotationElement (DoNotationLet ds) =
- fmap concat $ sequence
+ concat <$> sequence
[ return "let "
, withIndent $ prettyPrintMany prettyPrintDeclaration ds
]
prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el
+prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String
+prettyPrintObject' [] = return "{}"
+prettyPrintObject' ps = concat <$> sequence
+ [ return "{\n"
+ , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
+ , return "\n"
+ , currentIndent
+ , return "}"
+ ]
+
ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
ifThenElse = mkPattern match
where
@@ -144,6 +151,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 _ = Nothing
app :: Pattern PrinterState Expr (String, Expr)
@@ -188,17 +196,17 @@ prettyPrintBinderAtom = mkPattern' match
match (BooleanBinder True) = return "true"
match (BooleanBinder False) = return "false"
match (VarBinder ident) = return $ show ident
- match (ConstructorBinder ctor args) = fmap concat $ sequence
+ match (ConstructorBinder ctor args) = concat <$> sequence
[ return $ show ctor ++ " "
, unwords <$> forM args match
]
- match (ObjectBinder bs) = fmap concat $ sequence
+ match (ObjectBinder bs) = concat <$> sequence
[ return "{\n"
, withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
, currentIndent
, return "}"
]
- match (ArrayBinder bs) = fmap concat $ sequence
+ match (ArrayBinder bs) = concat <$> sequence
[ return "["
, unwords <$> mapM prettyPrintBinder' bs
, return "]"
@@ -229,13 +237,13 @@ matchConsBinder = mkPattern match'
match' _ = Nothing
prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
-prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
+prettyPrintObjectPropertyBinder (key, binder) = concat <$> sequence
[ return $ prettyPrintObjectKey key ++ ": "
, prettyPrintBinder' binder
]
-prettyPrintObjectProperty :: (String, Expr) -> StateT PrinterState Maybe String
-prettyPrintObjectProperty (key, value) = fmap concat $ sequence
+prettyPrintObjectProperty :: (String, Maybe Expr) -> StateT PrinterState Maybe String
+prettyPrintObjectProperty (key, value) = concat <$> sequence
[ return $ prettyPrintObjectKey key ++ ": "
- , prettyPrintValue' value
+ , maybe (pure "_") prettyPrintValue' value
]
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 46f25de..0a5bc05 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -23,20 +23,23 @@ import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Supply
-import Language.PureScript.Sugar.Operators as S
-import Language.PureScript.Sugar.DoNotation as S
-import Language.PureScript.Sugar.CaseDeclarations as S
-import Language.PureScript.Sugar.TypeDeclarations as S
import Language.PureScript.Sugar.BindingGroups as S
-import Language.PureScript.Sugar.TypeClasses as S
+import Language.PureScript.Sugar.CaseDeclarations as S
+import Language.PureScript.Sugar.DoNotation as S
import Language.PureScript.Sugar.Names as S
+import Language.PureScript.Sugar.ObjectWildcards as S
+import Language.PureScript.Sugar.Operators as S
+import Language.PureScript.Sugar.TypeClasses as S
+import Language.PureScript.Sugar.TypeDeclarations as S
-- |
-- The desugaring pipeline proceeds as follows:
--
--- * Introduce type synonyms for type class dictionaries
+-- * Remove signed literals in favour of `negate` applications
--
--- * Rebracket user-defined binary operators
+-- * Desugar object literals with wildcards into lambdas
+--
+-- * Desugar operator sections
--
-- * Desugar do-notation using the @Prelude.Monad@ type class
--
@@ -44,13 +47,19 @@ import Language.PureScript.Sugar.Names as S
--
-- * Desugar type declarations into value declarations with explicit type annotations
--
--- * Group mutually recursive value and data declarations into binding groups.
---
-- * Qualify any unqualified names and types
--
+-- * Rebracket user-defined binary operators
+--
+-- * Introduce type synonyms for type class dictionaries
+--
+-- * Group mutually recursive value and data declarations into binding groups.
+--
desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugar = map removeSignedLiterals
- >>> mapM desugarDoModule
+ >>> mapM desugarObjectConstructors
+ >=> mapM desugarOperatorSections
+ >=> mapM desugarDoModule
>=> desugarCasesModule
>=> lift . (desugarTypeDeclarationsModule
>=> desugarImports
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 5f9733d..ea79d11 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -54,8 +54,8 @@ data Exports = Exports
, exportedTypeClasses :: [ProperName]
-- |
-- The values exported from each module
- , exportedValues :: [Ident]
--
+ , exportedValues :: [Ident]
} deriving (Show)
-- |
@@ -105,15 +105,26 @@ addEmptyModule env name =
--
addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment
addType env mn name dctors = updateExportedModule env mn $ \m -> do
- types' <- addExport (exportedTypes m) (name, dctors)
- return $ m { exportedTypes = types' }
+ let exTypes = exportedTypes m
+ let exDctors = snd `concatMap` exTypes
+ let exClasses = exportedTypeClasses m
+ when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name
+ when (name `elem` exClasses) $ throwConflictingDefError "Type" "type class" name
+ forM_ dctors $ \dctor -> do
+ when (dctor `elem` exDctors) $ throwMultipleDefError "data constructor" dctor
+ when (dctor `elem` exClasses) $ throwConflictingDefError "Data constructor" "type class" dctor
+ return $ m { exportedTypes = (name, dctors) : exTypes }
-- |
-- Adds a class to the export environment.
--
addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
addTypeClass env mn name = updateExportedModule env mn $ \m -> do
- classes <- addExport (exportedTypeClasses m) name
+ let exTypes = exportedTypes m
+ let exDctors = snd `concatMap` exTypes
+ when (any ((== name) . fst) exTypes) $ throwConflictingDefError "Type class" "type" name
+ when (name `elem` exDctors) $ throwConflictingDefError "Type class" "data constructor" name
+ classes <- addExport "type class" (exportedTypeClasses m) name
return $ m { exportedTypeClasses = classes }
-- |
@@ -121,17 +132,17 @@ addTypeClass env mn name = updateExportedModule env mn $ \m -> do
--
addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
addValue env mn name = updateExportedModule env mn $ \m -> do
- values <- addExport (exportedValues m) name
+ values <- addExport "value" (exportedValues m) name
return $ m { exportedValues = values }
-- |
-- Adds an entry to a list of exports unless it is already present, in which case an error is
-- returned.
--
-addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a]
-addExport exports name =
+addExport :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack [a]
+addExport what exports name =
if name `elem` exports
- then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing
+ then throwMultipleDefError what name
else return $ name : exports
-- |
@@ -221,7 +232,7 @@ renameInModule imports exports (Module mn decls exps) =
updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
updateValue (pos, bound) (Let ds val') = do
let args = mapMaybe letBoundVariable ds
- unless (length (nub args) == length args) $
+ unless (length (nub args) == length args) $
throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing
return ((pos, args ++ bound), Let ds val')
where
@@ -327,7 +338,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
- addDecl mn env (PositionedDeclaration _ _ d) = addDecl mn env d
+ addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d
addDecl _ env _ = return env
-- |
@@ -523,3 +534,19 @@ resolveImport currentModule importModule exps imps impQual =
if item `elem` exports
then return item
else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
+
+-- |
+-- Raises an error for when there is more than one definition for something.
+--
+throwMultipleDefError :: (Show a) => String -> a -> Either ErrorStack b
+throwMultipleDefError what name = throwError $
+ mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing
+
+-- |
+-- Raises an error for when there is a conflicting definition for something, for example, a type
+-- class and data constructor of the same name.
+--
+throwConflictingDefError :: (Show a) => String -> String -> a -> Either ErrorStack b
+throwConflictingDefError what1 what2 name = throwError $
+ mkErrorStack (what1 ++ " '" ++ show name ++ "' cannot be defined in the same module as a " ++ what2 ++ " of the same name") Nothing
+
diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs
new file mode 100644
index 0000000..00d6872
--- /dev/null
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -0,0 +1,58 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Sugar.ObjectWildcards
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Sugar.ObjectWildcards (
+ desugarObjectConstructors
+) where
+
+import Control.Applicative
+import Control.Arrow (second)
+
+import Data.List (partition)
+import Data.Maybe (isJust, fromJust, catMaybes)
+
+import Language.PureScript.AST
+import Language.PureScript.Errors
+import Language.PureScript.Names
+import Language.PureScript.Supply
+
+desugarObjectConstructors :: Module -> SupplyT (Either ErrorStack) Module
+desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl ds <*> pure exts
+ where
+
+ desugarDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration
+ (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return
+
+ desugarExpr :: Expr -> SupplyT (Either ErrorStack) Expr
+ desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
+ desugarExpr (ObjectUpdater obj ps) = wrapLambda (ObjectUpdate obj) ps
+ desugarExpr (ObjectGetter prop) = do
+ arg <- Ident <$> freshName
+ return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
+ desugarExpr e = return e
+
+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> SupplyT (Either ErrorStack) Expr
+ wrapLambda mkVal ps =
+ let (props, args) = partition (isJust . snd) ps
+ in if null args
+ then return . mkVal $ second fromJust `map` props
+ else do
+ (args', ps') <- unzip <$> mapM mkProp ps
+ return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
+
+ mkProp :: (String, Maybe Expr) -> SupplyT (Either ErrorStack) (Maybe Ident, (String, Expr))
+ mkProp (name, Just e) = return (Nothing, (name, e))
+ mkProp (name, Nothing) = do
+ arg <- Ident <$> freshName
+ return (Just arg, (name, Var (Qualified Nothing arg)))
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 277c1dc..66b57f8 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -21,12 +21,14 @@
module Language.PureScript.Sugar.Operators (
rebracket,
- removeSignedLiterals
+ removeSignedLiterals,
+ desugarOperatorSections
) where
-import Language.PureScript.Names
import Language.PureScript.AST
import Language.PureScript.Errors
+import Language.PureScript.Names
+import Language.PureScript.Supply
import Control.Applicative
import Control.Monad.State
@@ -148,3 +150,16 @@ matchOp op = do
ident <- parseOp
guard $ ident == op
+desugarOperatorSections :: Module -> SupplyT (Either ErrorStack) Module
+desugarOperatorSections (Module mn ds exts) = Module mn <$> mapM goDecl ds <*> pure exts
+ where
+
+ goDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration
+ (goDecl, _, _) = everywhereOnValuesM return goExpr return
+
+ goExpr :: Expr -> SupplyT (Either ErrorStack) Expr
+ goExpr (OperatorSection op (Left val)) = return $ App (Var op) val
+ goExpr (OperatorSection op (Right val)) = do
+ arg <- Ident <$> freshName
+ return $ Abs (Left arg) $ App (App (Var op) (Var (Qualified Nothing arg))) val
+ goExpr other = return other
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 0d919c9..dcaef98 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -130,6 +130,10 @@ unifyRows r1 r2 =
rest <- fresh
u1 =:= rowFromList (sd2, rest)
u2 =:= rowFromList (sd1, rest)
+ unifyRows' sd1 (SaturatedTypeSynonym name args) sd2 r2' = do
+ r1' <- expandTypeSynonym name $ args
+ unifyRows (rowFromList (sd1, r1')) (rowFromList (sd2, r2'))
+ unifyRows' sd1 r1' sd2 r2'@(SaturatedTypeSynonym _ _) = unifyRows' sd2 r2' sd1 r1'
unifyRows' [] REmpty [] REmpty = return ()
unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()