module Language.PureScript.Sugar.Operators.Binders where
import Prelude ()
import Prelude.Compat
import Control.Monad.Error.Class (MonadError(..))
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
import Language.PureScript.Crash
import Language.PureScript.AST
import Language.PureScript.Errors
import Language.PureScript.Names
import Language.PureScript.Sugar.Operators.Common
matchBinderOperators
:: forall m
. MonadError MultipleErrors m
=> [[(Qualified Ident, Associativity)]]
-> Binder
-> m Binder
matchBinderOperators ops = parseChains
where
parseChains :: Binder -> m Binder
parseChains b@BinaryNoParensBinder{} = bracketChain (extendChain b)
parseChains other = return other
extendChain :: Binder -> Chain Binder
extendChain (BinaryNoParensBinder op l r) = Left l : Right op : extendChain r
extendChain other = [Left other]
bracketChain :: Chain Binder -> m Binder
bracketChain =
either
(\_ -> internalError "matchBinderOperators: cannot reorder operators")
return
. P.parse opParser "operator expression"
opParser = P.buildExpressionParser (opTable ops fromOp reapply) parseValue <* P.eof
fromOp (OpBinder q@(Qualified _ (Op _))) = Just q
fromOp _ = Nothing
reapply = BinaryNoParensBinder . OpBinder