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 (MonadSupply)
import Data.List (foldl')
import Language.PureScript.AST (Binder(..), CaseAlternative(..), Declaration, DoNotationElement(..), Expr(..), pattern MkUnguarded, Module(..), SourceSpan, WhereProvenance(..), declSourceSpan, everywhereOnValuesM)
import Language.PureScript.Errors (MultipleErrors, parU, rethrowWithPosition)
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), byMaybeModuleName, freshIdent')
import Language.PureScript.Constants.Libs qualified 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)