purescript 0.6.4.1 → 0.6.5

raw patch · 18 files changed

+390/−62 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• examples/passing/ObjectGetter.purs +11/−0
• examples/passing/ObjectUpdater.purs +32/−0
• examples/passing/ObjectWildcards.purs +31/−0
• examples/passing/OperatorSections.purs +21/−0
• examples/passing/RowSynonyms.purs +46/−0
• psc-make/Main.hs +2/−2
• purescript.cabal +2/−1
• src/Language/PureScript/AST/Declarations.hs +20/−0
• src/Language/PureScript/AST/Traversals.hs +26/−1
• src/Language/PureScript/Parser/Declarations.hs +21/−8
• src/Language/PureScript/Parser/Lexer.hs +7/−0
• src/Language/PureScript/Parser/Types.hs +1/−1
• src/Language/PureScript/Pretty/Values.hs +35/−27
• src/Language/PureScript/Sugar.hs +19/−10
• src/Language/PureScript/Sugar/Names.hs +37/−10
• src/Language/PureScript/Sugar/ObjectWildcards.hs +58/−0
• src/Language/PureScript/Sugar/Operators.hs +17/−2
• src/Language/PureScript/TypeChecker/Unify.hs +4/−0

@@ -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!" }

@@ -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

@@ -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

@@ -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!"

@@ -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

@@ -127,13 +127,13 @@  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

@@ -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 @@                      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

@@ -312,6 +312,11 @@   --   | 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 @@   --   | 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@@ -327,6 +342,11 @@   -- Partial record update   --   | 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   --

@@ -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 @@   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 @@   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 @@   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 @@   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 @@   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 @@   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

@@ -285,11 +285,13 @@ 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 @@             , P.try parseBooleanLiteral             , parseArrayLiteral             , P.try parseObjectLiteral+            , P.try parseObjectGetter             , parseAbs             , P.try parseConstructor             , P.try parseVar@@ -350,13 +353,20 @@             , parseIfThenElse             , parseDo             , parseLet-            , Parens <$> parens parseValue ]+            , P.try $ Parens <$> parens parseValue+            , parseOperatorSection ] -parsePropertyUpdate :: TokenParser (String, Expr)+parseOperatorSection :: TokenParser Expr+parseOperatorSection = parens $ left <|> right+  where+  right = OperatorSection <$> parseIdentInfix <* indented <*> (Right <$> parseValueAtom)+  left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseIdentInfix++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 @@             , parseDoNotationLet             , P.try (DoNotationValue <$> parseValue) ] +parseObjectGetter :: TokenParser Expr+parseObjectGetter = ObjectGetter <$> parens (dot *> C.indented *> (lname <|> stringLiteral))+ -- | -- Parse a value --@@ -392,7 +405,7 @@   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 @@                                <*> (C.indented *> parseBinder)  parseNullBinder :: TokenParser Binder-parseNullBinder = reserved "_" *> return NullBinder+parseNullBinder = underscore *> return NullBinder  parseIdentifierAndBinder :: TokenParser (String, Binder) parseIdentifierAndBinder = do

@@ -47,6 +47,7 @@   , comma   , semi   , at+  , underscore   , semiSep   , semiSep1   , commaSep@@ -105,6 +106,7 @@   | Comma   | Semi   | At+  | Underscore   | LName String   | UName String   | Qualifier String@@ -133,6 +135,7 @@ 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 @@   , 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)@@ -348,6 +352,9 @@  at :: TokenParser () at = match At++underscore :: TokenParser ()+underscore = match Underscore  -- | -- Parse zero or more values separated by semicolons

@@ -45,7 +45,7 @@ parseObject = braces $ TypeApp tyObject <$> parseRow  parseTypeWildcard :: TokenParser Type-parseTypeWildcard = reserved "_" >> return TypeWildcard+parseTypeWildcard = underscore >> return TypeWildcard  parseTypeVariable :: TokenParser Type parseTypeVariable = do

@@ -21,7 +21,7 @@ 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 @@   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 @@     , 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 @@  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 @@  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 @@   prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v    prettyPrintGuardedValue (grd, val) =-    fmap concat $ sequence+    concat <$> sequence       [ return "| "       , prettyPrintValue' grd       , return " -> "@@ -116,18 +113,28 @@ 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 = 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 @@   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 @@   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     ]

@@ -23,34 +23,43 @@ 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 -- --  * Desugar top-level case declarations into explicit case expressions -- --  * 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

@@ -54,8 +54,8 @@   , exportedTypeClasses :: [ProperName]   -- |   -- The values exported from each module-  , exportedValues :: [Ident]   --+  , exportedValues :: [Ident]   } deriving (Show)  -- |@@ -105,15 +105,26 @@ -- 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 @@ -- 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 @@   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 @@   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 @@       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+

@@ -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)))

@@ -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 @@   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

@@ -130,6 +130,10 @@     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 ()