-- | This module implements the desugaring pass which replaces do-notation statements with
-- appropriate calls to bind.

module Language.PureScript.Sugar.DoNotation (desugarDoModule) where

import           Prelude

import           Control.Applicative ((<|>))
import           Control.Monad.Error.Class (MonadError(..))
import           Control.Monad.Supply.Class
import           Data.Maybe (fromMaybe)
import           Data.Monoid (First(..))
import           Language.PureScript.AST
import           Language.PureScript.Crash
import           Language.PureScript.Errors
import           Language.PureScript.Names
import qualified Language.PureScript.Constants.Prelude as C

-- | Replace all @DoNotationBind@ and @DoNotationValue@ constructors with
-- applications of the bind function in scope, and all @DoNotationLet@
-- constructors with let expressions.
desugarDoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
desugarDoModule :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Module -> m Module
desugarDoModule (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
desugarDo 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 do statement
desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
desugarDo :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Declaration -> m Declaration
desugarDo 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
  bind :: SourceSpan -> Maybe ModuleName -> Expr
  bind :: SourceSpan -> Maybe ModuleName -> Expr
bind 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. IsString a => a
C.bind))

  discard :: SourceSpan -> Maybe ModuleName -> Expr
  discard :: SourceSpan -> Maybe ModuleName -> Expr
discard 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. IsString a => a
C.discard))

  replace :: SourceSpan -> Expr -> m Expr
  replace :: SourceSpan -> Expr -> m Expr
replace SourceSpan
pos (Do Maybe ModuleName
m [DoNotationElement]
els) = SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr
go SourceSpan
pos Maybe ModuleName
m [DoNotationElement]
els
  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

  stripPositionedBinder :: Binder -> (Maybe SourceSpan, Binder)
  stripPositionedBinder :: Binder -> (Maybe SourceSpan, Binder)
stripPositionedBinder (PositionedBinder SourceSpan
ss [Comment]
_ Binder
b) =
    let (Maybe SourceSpan
ss', Binder
b') = Binder -> (Maybe SourceSpan, Binder)
stripPositionedBinder Binder
b
     in (Maybe SourceSpan
ss' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just SourceSpan
ss, Binder
b')
  stripPositionedBinder Binder
b =
    (forall a. Maybe a
Nothing, Binder
b)

  go :: SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr
  go :: SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr
go SourceSpan
_ Maybe ModuleName
_ [] = forall a. HasCallStack => String -> a
internalError String
"The impossible happened in desugarDo"
  go SourceSpan
_ Maybe ModuleName
_ [DoNotationValue Expr
val] = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
val
  go SourceSpan
pos Maybe ModuleName
m (DoNotationValue Expr
val : [DoNotationElement]
rest) = do
    Expr
rest' <- SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr
go SourceSpan
pos Maybe ModuleName
m [DoNotationElement]
rest
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App (SourceSpan -> Maybe ModuleName -> Expr
discard SourceSpan
pos Maybe ModuleName
m) Expr
val) (Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
pos Ident
UnusedIdent) Expr
rest')
  go SourceSpan
_ Maybe ModuleName
_ [DoNotationBind Binder
_ Expr
_] = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage
InvalidDoBind
  go SourceSpan
_ Maybe ModuleName
_ (DoNotationBind Binder
b Expr
_ : [DoNotationElement]
_) | First (Just Text
ident) <- forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Ident -> First Text
fromIdent (Binder -> [Ident]
binderNames Binder
b) =
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
CannotUseBindWithDo (Text -> Ident
Ident Text
ident)
    where
      fromIdent :: Ident -> First Text
fromIdent (Ident Text
i) | Text
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ forall a. IsString a => a
C.bind, forall a. IsString a => a
C.discard ] = forall a. Maybe a -> First a
First (forall a. a -> Maybe a
Just Text
i)
      fromIdent Ident
_ = forall a. Monoid a => a
mempty
  go SourceSpan
pos Maybe ModuleName
m (DoNotationBind Binder
binder Expr
val : [DoNotationElement]
rest) = do
    Expr
rest' <- SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr
go SourceSpan
pos Maybe ModuleName
m [DoNotationElement]
rest
    let (Maybe SourceSpan
mss, Binder
binder') = Binder -> (Maybe SourceSpan, Binder)
stripPositionedBinder Binder
binder
    let ss :: SourceSpan
ss = forall a. a -> Maybe a -> a
fromMaybe SourceSpan
pos Maybe SourceSpan
mss
    case Binder
binder' of
      Binder
NullBinder ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App (SourceSpan -> Maybe ModuleName -> Expr
bind SourceSpan
pos Maybe ModuleName
m) Expr
val) (Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
UnusedIdent) Expr
rest')
      VarBinder SourceSpan
_ Ident
ident ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App (SourceSpan -> Maybe ModuleName -> Expr
bind SourceSpan
pos Maybe ModuleName
m) Expr
val) (Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
ident) Expr
rest')
      Binder
_ -> do
        Ident
ident <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr
App (Expr -> Expr -> Expr
App (SourceSpan -> Maybe ModuleName -> Expr
bind SourceSpan
pos Maybe ModuleName
m) Expr
val) (Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
pos Ident
ident) ([Expr] -> [CaseAlternative] -> Expr
Case [SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
pos (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
ident)] [[Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
binder] [Expr -> GuardedExpr
MkUnguarded Expr
rest']]))
  go SourceSpan
_ Maybe ModuleName
_ [DoNotationLet [Declaration]
_] = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleErrorMessage -> MultipleErrors
errorMessage forall a b. (a -> b) -> a -> b
$ SimpleErrorMessage
InvalidDoLet
  go SourceSpan
pos Maybe ModuleName
m (DoNotationLet [Declaration]
ds : [DoNotationElement]
rest) = do
    let checkBind :: Declaration -> m ()
        checkBind :: Declaration -> m ()
checkBind (ValueDecl (SourceSpan
ss, [Comment]
_) i :: Ident
i@(Ident Text
name) NameKind
_ [Binder]
_ [GuardedExpr]
_)
          | Text
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ forall a. IsString a => a
C.bind, forall a. IsString a => a
C.discard ] = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
CannotUseBindWithDo Ident
i
        checkBind Declaration
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Declaration -> m ()
checkBind [Declaration]
ds
    Expr
rest' <- SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr
go SourceSpan
pos Maybe ModuleName
m [DoNotationElement]
rest
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
FromLet [Declaration]
ds Expr
rest'
  go SourceSpan
_ Maybe ModuleName
m (PositionedDoNotationElement SourceSpan
pos [Comment]
com DoNotationElement
el : [DoNotationElement]
rest) = forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SourceSpan -> m a -> m a
rethrowWithPosition SourceSpan
pos forall a b. (a -> b) -> a -> b
$ SourceSpan -> [Comment] -> Expr -> Expr
PositionedValue SourceSpan
pos [Comment]
com forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr
go SourceSpan
pos Maybe ModuleName
m (DoNotationElement
el forall a. a -> [a] -> [a]
: [DoNotationElement]
rest)