-- | This module implements the desugaring pass which replaces ado-notation statements with
-- appropriate calls to pure and apply.

module Language.PureScript.Sugar.AdoNotation (desugarAdoModule) where

import           Prelude 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.Libs 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 :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Module -> m Module
desugarAdoModule (Module SourceSpan
ss [Comment]
coms ModuleName
mn [Declaration]
ds Maybe [DeclarationRef]
exts) = SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
mn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU [Declaration]
ds forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Declaration -> m Declaration
desugarAdo forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DeclarationRef]
exts

-- | Desugar a single ado statement
desugarAdo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
desugarAdo :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Declaration -> m Declaration
desugarAdo Declaration
d =
  let ss :: SourceSpan
ss = Declaration -> SourceSpan
declSourceSpan Declaration
d
      (Declaration -> m Declaration
f, Expr -> m Expr
_, Binder -> m Binder
_) = forall (m :: * -> *).
Monad m =>
(Declaration -> m Declaration)
-> (Expr -> m Expr)
-> (Binder -> m Binder)
-> (Declaration -> m Declaration, Expr -> m Expr,
    Binder -> m Binder)
everywhereOnValuesM forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan -> Expr -> m Expr
replace SourceSpan
ss) forall (m :: * -> *) a. Monad m => a -> m a
return
  in forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Declaration -> m Declaration
f Declaration
d
  where
  pure' :: SourceSpan -> Maybe ModuleName -> Expr
  pure' :: SourceSpan -> Maybe ModuleName -> Expr
pure' SourceSpan
ss Maybe ModuleName
m = SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified (Maybe ModuleName -> QualifiedBy
byMaybeModuleName Maybe ModuleName
m) (Text -> Ident
Ident forall a. (Eq a, IsString a) => a
C.S_pure))

  map' :: SourceSpan -> Maybe ModuleName -> Expr
  map' :: SourceSpan -> Maybe ModuleName -> Expr
map' SourceSpan
ss Maybe ModuleName
m = SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified (Maybe ModuleName -> QualifiedBy
byMaybeModuleName Maybe ModuleName
m) (Text -> Ident
Ident forall a. (Eq a, IsString a) => a
C.S_map))

  apply :: SourceSpan -> Maybe ModuleName -> Expr
  apply :: SourceSpan -> Maybe ModuleName -> Expr
apply SourceSpan
ss Maybe ModuleName
m = SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified (Maybe ModuleName -> QualifiedBy
byMaybeModuleName Maybe ModuleName
m) (Text -> Ident
Ident forall a. (Eq a, IsString a) => a
C.S_apply))

  replace :: SourceSpan -> Expr -> m Expr
  replace :: SourceSpan -> Expr -> m Expr
replace SourceSpan
pos (Ado Maybe ModuleName
m [DoNotationElement]
els Expr
yield) = do
    (Expr
func, [Expr]
args) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (SourceSpan
-> (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr])
go SourceSpan
pos) (Expr
yield, []) (forall a. [a] -> [a]
reverse [DoNotationElement]
els)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [Expr]
args of
      [] -> Expr -> Expr -> Expr
App (SourceSpan -> Maybe ModuleName -> Expr
pure' SourceSpan
pos Maybe ModuleName
m) Expr
func
      Expr
hd : [Expr]
tl -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Expr
a Expr
b -> Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App (SourceSpan -> Maybe ModuleName -> Expr
apply SourceSpan
pos Maybe ModuleName
m) Expr
a) Expr
b) (Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App (SourceSpan -> Maybe ModuleName -> Expr
map' SourceSpan
pos Maybe ModuleName
m) Expr
func) Expr
hd) [Expr]
tl
  replace SourceSpan
_ (PositionedValue SourceSpan
pos [Comment]
com Expr
v) = SourceSpan -> [Comment] -> Expr -> Expr
PositionedValue SourceSpan
pos [Comment]
com forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
pos (SourceSpan -> Expr -> m Expr
replace SourceSpan
pos Expr
v)
  replace SourceSpan
_ Expr
other = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
other

  go :: SourceSpan -> (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr])
  go :: SourceSpan
-> (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr])
go SourceSpan
_ (Expr
yield, [Expr]
args) (DoNotationValue Expr
val) =
    forall (m :: * -> *) a. Monad m => a -> m a
return (Binder -> Expr -> Expr
Abs Binder
NullBinder Expr
yield, Expr
val forall a. a -> [a] -> [a]
: [Expr]
args)
  go SourceSpan
_ (Expr
yield, [Expr]
args) (DoNotationBind (VarBinder SourceSpan
ss Ident
ident) Expr
val) =
    forall (m :: * -> *) a. Monad m => a -> m a
return (Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
ident) Expr
yield, Expr
val forall a. a -> [a] -> [a]
: [Expr]
args)
  go SourceSpan
ss (Expr
yield, [Expr]
args) (DoNotationBind Binder
binder Expr
val) = do
    Ident
ident <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
    let abs :: Expr
abs = Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
ident)
                  ([Expr] -> [CaseAlternative] -> Expr
Case [SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
ident)]
                        [[Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
binder] [Expr -> GuardedExpr
MkUnguarded Expr
yield]])
    forall (m :: * -> *) a. Monad m => a -> m a
return (Expr
abs, Expr
val forall a. a -> [a] -> [a]
: [Expr]
args)
  go SourceSpan
_ (Expr
yield, [Expr]
args) (DoNotationLet [Declaration]
ds) = do
    forall (m :: * -> *) a. Monad m => a -> m a
return (WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
FromLet [Declaration]
ds Expr
yield, [Expr]
args)
  go SourceSpan
_ (Expr, [Expr])
acc (PositionedDoNotationElement SourceSpan
pos [Comment]
com DoNotationElement
el) =
    forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
pos forall a b. (a -> b) -> a -> b
$ do
      (Expr
yield, [Expr]
args) <- SourceSpan
-> (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr])
go SourceSpan
pos (Expr, [Expr])
acc DoNotationElement
el
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [Expr]
args of
        [] -> (SourceSpan -> [Comment] -> Expr -> Expr
PositionedValue SourceSpan
pos [Comment]
com Expr
yield, [Expr]
args)
        (Expr
a : [Expr]
as) -> (Expr
yield, SourceSpan -> [Comment] -> Expr -> Expr
PositionedValue SourceSpan
pos [Comment]
com Expr
a forall a. a -> [a] -> [a]
: [Expr]
as)