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