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