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
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
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)