{-# LANGUAGE PatternGuards #-}
module Language.PureScript.Sugar.AdoNotation (desugarAdoModule) where
import Prelude.Compat hiding (abs)
import Control.Monad (foldM)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
import Data.List (foldl')
import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Names
import qualified Language.PureScript.Constants as C
desugarAdoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
desugarAdoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarAdo <*> pure exts
desugarAdo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
desugarAdo d =
let (f, _, _) = everywhereOnValuesM return replace return
in f d
where
pure' :: Maybe ModuleName -> Expr
pure' m = Var nullSourceSpan (Qualified m (Ident C.pure'))
map' :: Maybe ModuleName -> Expr
map' m = Var nullSourceSpan (Qualified m (Ident C.map))
apply :: Maybe ModuleName -> Expr
apply m = Var nullSourceSpan (Qualified m (Ident C.apply))
replace :: Expr -> m Expr
replace (Ado m els yield) = do
(func, args) <- foldM go (yield, []) (reverse els)
return $ case args of
[] -> App (pure' m) func
hd : tl -> foldl' (\a b -> App (App (apply m) a) b) (App (App (map' m) func) hd) tl
replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
replace other = return other
go :: (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr])
go (yield, args) (DoNotationValue val) =
return (Abs NullBinder yield, val : args)
go (yield, args) (DoNotationBind (VarBinder ss ident) val) =
return (Abs (VarBinder ss ident) yield, val : args)
go (yield, args) (DoNotationBind binder val) = do
ident <- freshIdent'
let abs = Abs (VarBinder nullSourceSpan ident)
(Case [Var nullSourceSpan (Qualified Nothing ident)]
[CaseAlternative [binder] [MkUnguarded yield]])
return (abs, val : args)
go (yield, args) (DoNotationLet ds) = do
return (Let FromLet ds yield, args)
go acc (PositionedDoNotationElement pos com el) =
rethrowWithPosition pos $ do
(yield, args) <- go acc el
return $ case args of
[] -> (PositionedValue pos com yield, args)
(a : as) -> (yield, PositionedValue pos com a : as)