purescript · paf31 · Sep 10, 2017 · May 13, 2017 · May 14, 2017 · May 15, 2017
diff --git a/examples/passing/Ado.purs b/examples/passing/Ado.purs
@@ -0,0 +1,77 @@
+module Main where
+
+import Prelude
+import Control.Monad.Eff.Console (log)
+import Control.Monad.Eff.Ref (newRef, writeRef, readRef)
+
+data Maybe a = Nothing | Just a
+
+instance functorMaybe :: Functor Maybe where
+  map f Nothing = Nothing
+  map f (Just x) = Just (f x)
+
+instance applyMaybe :: Apply Maybe where
+  apply (Just f) (Just x) = Just (f x)
+  apply _ _ = Nothing
+
+instance applicativeMaybe :: Applicative Maybe where
+  pure = Just
+
+test1 = \_ -> ado
+  in "abc"
+
+test2 = \_ -> ado
+  x <- Just 1.0
+  y <- Just 2.0
+  in x + y
+
+test3 = \_ -> ado
+  _ <- Just 1.0
+  _ <- Nothing :: Maybe Number
+  in 2.0
+
+test4 mx my = ado
+  x <- mx
+  y <- my
+  in x + y + 1.0
+
+test5 mx my mz = ado
+  x <- mx
+  y <- my
+  let sum = x + y
+  z <- mz
+  in z + sum + 1.0
+
+test6 mx = \_ -> ado
+  let
+    f :: forall a. Maybe a -> a
+    f (Just x) = x
+  in f mx
+
+test8 = \_ -> ado
+  in (ado
+    in 1.0)
+
+test9 = \_ -> (+) <$> Just 1.0 <*> Just 2.0
+
+test10 _ = ado
+  let
+    f x = g x * 3.0
+    g x = f x / 2.0
+  in f 10.0
+
+test11 = \_ -> ado
+  x <- pure 1
+  y <- pure "A"
+  z <- pure []
+  in show (x :: Int) <> y <> show (z :: Array Int)
+
+main = do
+  r <- newRef "X"
+  log =<< ado
+    _ <- writeRef r "D"
+    a <- readRef r
+    b <- pure "o"
+    let c = "n"
+    d <- pure "e"
+    in a <> b <> c <> d
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -451,7 +451,7 @@ getValueDeclaration (ValueDeclaration d) = Just d
 getValueDeclaration _ = Nothing
 
 pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
-pattern ValueDecl sann ident name binders expr 
+pattern ValueDecl sann ident name binders expr
   = ValueDeclaration (ValueDeclarationData sann ident name binders expr)
 
 -- |
@@ -763,6 +763,9 @@ data Expr
   -- A proxy value
   --
   | Proxy Type
+  -- An ado-notation block
+  --
+  | Ado [DoNotationElement] Expr
   -- |
   -- An application of a typeclass dictionary constructor. The value should be
   -- an ObjectLiteral.

diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
@@ -77,6 +77,7 @@ everywhereOnValues f g h = (f', g', h')
   g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)
   g' (Let ds v) = g (Let (fmap f' ds) (g' v))
   g' (Do es) = g (Do (fmap handleDoNotationElement es))
+  g' (Ado es v) = g (Ado (fmap handleDoNotationElement es) (g' v))
   g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v))
   g' other = g other
 
@@ -150,6 +151,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
   g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty
   g' (Let ds v) = Let <$> traverse (f' <=< f) ds <*> (g v >>= g')
   g' (Do es) = Do <$> traverse handleDoNotationElement es
+  g' (Ado es v) = Ado <$> traverse handleDoNotationElement es <*> (g v >>= g')
   g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')
   g' other = g other
 
@@ -194,7 +196,7 @@ everywhereOnValuesM f g h = (f', g', h')
 
   f' :: Declaration -> m Declaration
   f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
-  f' (ValueDecl sa name nameKind bs val) = 
+  f' (ValueDecl sa name nameKind bs val) =
     ValueDecl sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val >>= f
   f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
   f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f
@@ -218,6 +220,7 @@ everywhereOnValuesM f g h = (f', g', h')
   g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g
   g' (Let ds v) = (Let <$> traverse f' ds <*> g' v) >>= g
   g' (Do es) = (Do <$> traverse handleDoNotationElement es) >>= g
+  g' (Ado es v) = (Ado <$> traverse handleDoNotationElement es <*> g' v) >>= g
   g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g
   g' other = g other
 
@@ -289,6 +292,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
   g' v@(TypedValue _ v1 _) = g v <> g' v1
   g' v@(Let ds v1) = foldl (<>) (g v) (fmap f' ds) <> g' v1
   g' v@(Do es) = foldl (<>) (g v) (fmap j' es)
+  g' v@(Ado es v1) = foldl (<>) (g v) (fmap j' es) <> g' v1
   g' v@(PositionedValue _ _ v1) = g v <> g' v1
   g' v = g v
 
@@ -369,6 +373,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
   g' s (TypedValue _ v1 _) = g'' s v1
   g' s (Let ds v1) = foldl (<>) r0 (fmap (f'' s) ds) <> g'' s v1
   g' s (Do es) = foldl (<>) r0 (fmap (j'' s) es)
+  g' s (Ado es v1) = foldl (<>) r0 (fmap (j'' s) es) <> g'' s v1
   g' s (PositionedValue _ _ v1) = g'' s v1
   g' _ _ = r0
 
@@ -453,6 +458,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
   g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty
   g' s (Let ds v) = Let <$> traverse (f'' s) ds <*> g'' s v
   g' s (Do es) = Do <$> traverse (j'' s) es
+  g' s (Ado es v) = Ado <$> traverse (j'' s) es <*> g'' s v
   g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v
   g' _ other = return other
 
@@ -546,6 +552,9 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
     let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))
     in foldMap (f'' s') ds <> g'' s' v1
   g' s (Do es) = fold . snd . mapAccumL j'' s $ es
+  g' s (Ado es v1) =
+    let s' = S.union s (foldMap (fst . j'' s) es)
+    in g'' s' v1
   g' s (PositionedValue _ _ v1) = g'' s v1
   g' _ _ = mempty
 

diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
@@ -426,6 +426,7 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice
                  , parseCase
                  , parseIfThenElse
                  , parseDo
+                 , parseAdo
                  , parseLet
                  , parseProxy
                  , P.try $ Parens <$> parens parseValue
@@ -464,6 +465,14 @@ parseDo = do
   indented
   Do <$> mark (P.many1 (same *> mark parseDoNotationElement))
 
+parseAdo :: TokenParser Expr
+parseAdo = do
+  reserved "ado"
+  indented
+  elements <- mark (P.many (same *> mark parseDoNotationElement))
+  yield <- mark (reserved "in" *> parseValue)
+  pure $ Ado elements yield
+
 parseDoNotationLet :: TokenParser DoNotationElement
 parseDoNotationLet = DoNotationLet <$> (reserved "let" *> indented *> mark (P.many1 (same *> parseLocalDeclaration)))
 

diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
@@ -570,6 +570,7 @@ reservedPsNames = [ "data"
                   , "then"
                   , "else"
                   , "do"
+                  , "ado"
                   , "let"
                   , "true"
                   , "false"

diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
@@ -80,6 +80,9 @@ prettyPrintValue d (Do els) =
   text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
 prettyPrintValue _ (Proxy ty) =
   text "@" <> typeAtomAsBox ty
+prettyPrintValue d (Ado els yield) =
+  text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) //
+  (text "in " <> prettyPrintValue (d - 1) yield)
 prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys
 prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name))
 prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
@@ -18,6 +18,7 @@ import Language.PureScript.Externs
 import Language.PureScript.Sugar.BindingGroups as S
 import Language.PureScript.Sugar.CaseDeclarations as S
 import Language.PureScript.Sugar.DoNotation as S
+import Language.PureScript.Sugar.AdoNotation as S
 import Language.PureScript.Sugar.LetPattern as S
 import Language.PureScript.Sugar.Names as S
 import Language.PureScript.Sugar.ObjectWildcards as S
@@ -37,6 +38,8 @@ import Language.PureScript.Sugar.TypeDeclarations as S
 --
 --  * Desugar do-notation
 --
+--  * Desugar ado-notation
+--
 --  * Desugar top-level case declarations into explicit case expressions
 --
 --  * Desugar type declarations into value declarations with explicit type annotations
@@ -58,6 +61,7 @@ desugar externs =
   map desugarSignedLiterals
     >>> traverse desugarObjectConstructors
     >=> traverse desugarDoModule
+    >=> traverse desugarAdoModule
     >=> map desugarLetPatternModule
     >>> traverse desugarCasesModule
     >=> traverse desugarTypeDeclarationsModule

diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs
@@ -0,0 +1,67 @@
+-- | This module implements the desugaring pass which replaces ado-notation statements with
+-- appropriate calls to pure and apply.
+
+{-# LANGUAGE PatternGuards #-}
+
+module Language.PureScript.Sugar.AdoNotation (desugarAdoModule) where
+
+import           Prelude.Compat hiding (abs)
+
+import           Control.Monad (foldM)
+import           Control.Monad.Error.Class (MonadError(..))
+import           Control.Monad.Supply.Class
+import           Data.List (foldl')
+import           Language.PureScript.AST
+import           Language.PureScript.Errors
+import           Language.PureScript.Names
+import qualified Language.PureScript.Constants as C
+
+-- | Replace all @AdoNotationBind@ and @AdoNotationValue@ constructors with
+-- applications of the pure and apply functions in scope, and all @AdoNotationLet@
+-- constructors with let expressions.
+desugarAdoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
+desugarAdoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarAdo <*> pure exts
+
+-- | Desugar a single ado statement
+desugarAdo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
+desugarAdo d =
+  let (f, _, _) = everywhereOnValuesM return replace return
+  in f d
+  where
+  pure' :: Expr
+  pure' = Var (Qualified Nothing (Ident C.pure'))
+
+  map' :: Expr
+  map' = Var (Qualified Nothing (Ident C.map))
+
+  apply :: Expr
+  apply = Var (Qualified Nothing (Ident C.apply))
+
+  replace :: Expr -> m Expr
+  replace (Ado els yield) = do
+    (func, args) <- foldM go (yield, []) (reverse els)
+    return $ case args of
+      [] -> App pure' func
+      hd : tl -> foldl' (\a b -> App (App apply a) b) (App (App map' func) hd) tl
+  replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
+  replace other = return other
+
+  go :: (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr])
+  go (yield, args) (DoNotationValue val) =
+    return (Abs NullBinder yield, val : args)
+  go (yield, args) (DoNotationBind (VarBinder ident) val) =
+    return (Abs (VarBinder ident) yield, val : args)
+  go (yield, args) (DoNotationBind binder val) = do
+    ident <- freshIdent'
+    let abs = Abs (VarBinder ident)
+                  (Case [Var (Qualified Nothing ident)]
+                        [CaseAlternative [binder] [MkUnguarded yield]])
+    return (abs, val : args)
+  go (yield, args) (DoNotationLet ds) = do
+    return (Let ds yield, args)
+  go acc (PositionedDoNotationElement pos com el) =
+    rethrowWithPosition pos $ do
+      (yield, args) <- go acc el
+      return $ case args of
+        [] -> (PositionedValue pos com yield, args)
+        (a : as) -> (yield, PositionedValue pos com a : as)
diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs
@@ -33,12 +33,12 @@ completionTestData supportModuleNames =
   , (":b",  [":browse"])
 
   -- :browse should complete module names
-  , (":b Control.Monad.E",    map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried"])
-  , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried"])
+  , (":b Control.Monad.E",    map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"])
+  , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"])
 
   -- import should complete module names
-  , ("import Control.Monad.E",    map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried"])
-  , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried"])
+  , ("import Control.Monad.E",    map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"])
+  , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"])
 
   -- :quit, :help, :reload, :clear should not complete
   , (":help ", [])

diff --git a/tests/support/bower.json b/tests/support/bower.json
@@ -29,6 +29,7 @@
     "purescript-prelude": "3.1.0",
     "purescript-proxy": "2.1.0",
     "purescript-psci-support": "3.0.0",
+    "purescript-refs": "3.0.0",
     "purescript-st": "3.0.0",
     "purescript-strings": "3.3.0",
     "purescript-symbols": "3.0.0",