-- | 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 (MonadSupply)
import Data.Maybe (fromMaybe)
import Data.Monoid (First(..))
import Language.PureScript.AST (Binder(..), CaseAlternative(..), Declaration, DoNotationElement(..), Expr(..), pattern MkUnguarded, Module(..), SourceSpan, pattern ValueDecl, WhereProvenance(..), binderNames, declSourceSpan, everywhereOnValuesM)
import Language.PureScript.Crash (internalError)
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', parU, rethrowWithPosition)
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), byMaybeModuleName, freshIdent')
import Language.PureScript.Constants.Libs qualified 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. (Eq a, IsString a) => a
C.S_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. (Eq a, IsString a) => a
C.S_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. (Eq a, IsString a) => a
C.S_bind, forall a. (Eq a, IsString a) => a
C.S_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. (Eq a, IsString a) => a
C.S_bind, forall a. (Eq a, IsString a) => a
C.S_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)