module Language.PureScript.Sugar.ObjectWildcards
( desugarObjectConstructors
, desugarDecl
) where
import Prelude
import Control.Monad (forM)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class (MonadSupply)
import Data.Foldable (toList)
import Data.List (foldl')
import Data.Maybe (catMaybes)
import Language.PureScript.AST
import Language.PureScript.Environment (NameKind(..))
import Language.PureScript.Errors (MultipleErrors, rethrowWithPosition)
import Language.PureScript.Names (pattern ByNullSourcePos, Ident, Qualified(..), freshIdent')
import Language.PureScript.PSString (PSString)
desugarObjectConstructors
:: forall m
. (MonadSupply m, MonadError MultipleErrors m)
=> Module
-> m Module
desugarObjectConstructors :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Module -> m Module
desugarObjectConstructors (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 (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Declaration -> m Declaration
desugarDecl [Declaration]
ds 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
desugarDecl :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
desugarDecl :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Declaration -> m Declaration
desugarDecl Declaration
d = forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition (Declaration -> SourceSpan
declSourceSpan Declaration
d) forall a b. (a -> b) -> a -> b
$ Declaration -> m Declaration
fn Declaration
d
where
(Declaration -> m Declaration
fn, 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)
everywhereOnValuesTopDownM forall (m :: * -> *) a. Monad m => a -> m a
return Expr -> m Expr
desugarExpr forall (m :: * -> *) a. Monad m => a -> m a
return
desugarExpr :: Expr -> m Expr
desugarExpr :: Expr -> m Expr
desugarExpr (Literal SourceSpan
ss (ObjectLiteral [(PSString, Expr)]
ps)) = ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr
wrapLambdaAssoc (SourceSpan -> Literal Expr -> Expr
Literal SourceSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(PSString, a)] -> Literal a
ObjectLiteral) [(PSString, Expr)]
ps
desugarExpr (ObjectUpdateNested Expr
obj PathTree Expr
ps) = Expr -> PathTree Expr -> m Expr
transformNestedUpdate Expr
obj PathTree Expr
ps
desugarExpr (Accessor PSString
prop Expr
u)
| Just [PSString]
props <- Expr -> Maybe [PSString]
peelAnonAccessorChain Expr
u = do
Ident
arg <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
nullSourceSpan Ident
arg) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PSString -> Expr -> Expr
Accessor (Ident -> Expr
argToExpr Ident
arg) (PSString
propforall a. a -> [a] -> [a]
:[PSString]
props)
desugarExpr (Case [Expr]
args [CaseAlternative]
cas) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Expr -> Bool
isAnonymousArgument [Expr]
args = do
[Maybe Ident]
argIdents <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Expr]
args Expr -> m (Maybe Ident)
freshIfAnon
let args' :: [Expr]
args' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` Ident -> Expr
argToExpr) [Expr]
args [Maybe Ident]
argIdents
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Binder -> Expr -> Expr
Abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> Ident -> Binder
VarBinder SourceSpan
nullSourceSpan) ([Expr] -> [CaseAlternative] -> Expr
Case [Expr]
args' [CaseAlternative]
cas) (forall a. [Maybe a] -> [a]
catMaybes [Maybe Ident]
argIdents)
desugarExpr (IfThenElse Expr
u Expr
t Expr
f) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Expr -> Bool
isAnonymousArgument [Expr
u, Expr
t, Expr
f] = do
Maybe Ident
u' <- Expr -> m (Maybe Ident)
freshIfAnon Expr
u
Maybe Ident
t' <- Expr -> m (Maybe Ident)
freshIfAnon Expr
t
Maybe Ident
f' <- Expr -> m (Maybe Ident)
freshIfAnon Expr
f
let if_ :: Expr
if_ = Expr -> Expr -> Expr -> Expr
IfThenElse (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expr
u Ident -> Expr
argToExpr Maybe Ident
u') (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expr
t Ident -> Expr
argToExpr Maybe Ident
t') (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expr
f Ident -> Expr
argToExpr Maybe Ident
f')
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Binder -> Expr -> Expr
Abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> Ident -> Binder
VarBinder SourceSpan
nullSourceSpan) Expr
if_ (forall a. [Maybe a] -> [a]
catMaybes [Maybe Ident
u', Maybe Ident
t', Maybe Ident
f'])
desugarExpr Expr
e = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
e
transformNestedUpdate :: Expr -> PathTree Expr -> m Expr
transformNestedUpdate :: Expr -> PathTree Expr -> m Expr
transformNestedUpdate Expr
obj PathTree Expr
ps = do
Ident
val <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
let valExpr :: Expr
valExpr = Ident -> Expr
argToExpr Ident
val
if Expr -> Bool
isAnonymousArgument Expr
obj
then Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
nullSourceSpan Ident
val) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *).
Traversable t =>
(t Expr -> Expr) -> t Expr -> m Expr
wrapLambda (Expr -> PathTree Expr -> Expr
buildUpdates Expr
valExpr) PathTree Expr
ps
else forall (t :: * -> *).
Traversable t =>
(t Expr -> Expr) -> t Expr -> m Expr
wrapLambda (Ident -> Expr -> Expr
buildLet Ident
val forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> PathTree Expr -> Expr
buildUpdates Expr
valExpr) PathTree Expr
ps
where
buildLet :: Ident -> Expr -> Expr
buildLet Ident
val = WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
FromLet [SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl (Declaration -> SourceSpan
declSourceSpan Declaration
d, []) Ident
val NameKind
Public [] [Expr -> GuardedExpr
MkUnguarded Expr
obj]]
buildUpdates :: Expr -> PathTree Expr -> Expr
buildUpdates :: Expr -> PathTree Expr -> Expr
buildUpdates Expr
val (PathTree AssocList PSString (PathNode Expr)
vs) = Expr -> [(PSString, Expr)] -> Expr
ObjectUpdate Expr
val ([PSString] -> (PSString, PathNode Expr) -> (PSString, Expr)
goLayer [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k t. AssocList k t -> [(k, t)]
runAssocList AssocList PSString (PathNode Expr)
vs) where
goLayer :: [PSString] -> (PSString, PathNode Expr) -> (PSString, Expr)
goLayer :: [PSString] -> (PSString, PathNode Expr) -> (PSString, Expr)
goLayer [PSString]
_ (PSString
key, Leaf Expr
expr) = (PSString
key, Expr
expr)
goLayer [PSString]
path (PSString
key, Branch (PathTree AssocList PSString (PathNode Expr)
branch)) =
let path' :: [PSString]
path' = [PSString]
path forall a. [a] -> [a] -> [a]
++ [PSString
key]
updates :: [(PSString, Expr)]
updates = [PSString] -> (PSString, PathNode Expr) -> (PSString, Expr)
goLayer [PSString]
path' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k t. AssocList k t -> [(k, t)]
runAssocList AssocList PSString (PathNode Expr)
branch
accessor :: Expr
accessor = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip PSString -> Expr -> Expr
Accessor) Expr
val [PSString]
path'
objectUpdate :: Expr
objectUpdate = Expr -> [(PSString, Expr)] -> Expr
ObjectUpdate Expr
accessor [(PSString, Expr)]
updates
in (PSString
key, Expr
objectUpdate)
wrapLambda :: forall t. Traversable t => (t Expr -> Expr) -> t Expr -> m Expr
wrapLambda :: forall (t :: * -> *).
Traversable t =>
(t Expr -> Expr) -> t Expr -> m Expr
wrapLambda t Expr -> Expr
mkVal t Expr
ps = do
t (Maybe Ident, Expr)
args <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr -> m (Maybe Ident, Expr)
processExpr t Expr
ps
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Binder -> Expr -> Expr
Abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> Ident -> Binder
VarBinder SourceSpan
nullSourceSpan) (t Expr -> Expr
mkVal (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (Maybe Ident, Expr)
args)) (forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (Maybe Ident, Expr)
args))
where
processExpr :: Expr -> m (Maybe Ident, Expr)
processExpr :: Expr -> m (Maybe Ident, Expr)
processExpr Expr
e = do
Maybe Ident
arg <- Expr -> m (Maybe Ident)
freshIfAnon Expr
e
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Ident
arg, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expr
e Ident -> Expr
argToExpr Maybe Ident
arg)
wrapLambdaAssoc :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr
wrapLambdaAssoc :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr
wrapLambdaAssoc [(PSString, Expr)] -> Expr
mkVal = forall (t :: * -> *).
Traversable t =>
(t Expr -> Expr) -> t Expr -> m Expr
wrapLambda ([(PSString, Expr)] -> Expr
mkVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k t. AssocList k t -> [(k, t)]
runAssocList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k t. [(k, t)] -> AssocList k t
AssocList
peelAnonAccessorChain :: Expr -> Maybe [PSString]
peelAnonAccessorChain :: Expr -> Maybe [PSString]
peelAnonAccessorChain (Accessor PSString
p Expr
e) = (PSString
p forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Maybe [PSString]
peelAnonAccessorChain Expr
e
peelAnonAccessorChain (PositionedValue SourceSpan
_ [Comment]
_ Expr
e) = Expr -> Maybe [PSString]
peelAnonAccessorChain Expr
e
peelAnonAccessorChain Expr
AnonymousArgument = forall a. a -> Maybe a
Just []
peelAnonAccessorChain Expr
_ = forall a. Maybe a
Nothing
freshIfAnon :: Expr -> m (Maybe Ident)
freshIfAnon :: Expr -> m (Maybe Ident)
freshIfAnon Expr
u
| Expr -> Bool
isAnonymousArgument Expr
u = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
argToExpr :: Ident -> Expr
argToExpr :: Ident -> Expr
argToExpr = SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
nullSourceSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos