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
    -- If we don't have an anonymous argument then we need to generate a let wrapper
    -- so that the object expression isn't re-evaluated for each nested update.
    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]]

      -- recursively build up the nested `ObjectUpdate` expressions
      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