module Language.PureScript.Sugar.Operators.Common where
import Prelude ()
import Prelude.Compat
import Control.Monad.State
import Data.Functor.Identity
import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as P
import qualified Text.Parsec.Expr as P
import Language.PureScript.AST
import Language.PureScript.Names
type Chain a = [Either a a]
toAssoc :: Associativity -> P.Assoc
toAssoc Infixl = P.AssocLeft
toAssoc Infixr = P.AssocRight
toAssoc Infix = P.AssocNone
token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a
token = P.token (const "") (const (P.initialPos ""))
parseValue :: P.Parsec (Chain a) () a
parseValue = token (either Just (const Nothing)) P.<?> "expression"
parseOp
:: (a -> (Maybe (Qualified Ident)))
-> P.Parsec (Chain a) () (Qualified Ident)
parseOp fromOp = token (either (const Nothing) fromOp) P.<?> "operator"
matchOp
:: (a -> (Maybe (Qualified Ident)))
-> Qualified Ident
-> P.Parsec (Chain a) () ()
matchOp fromOp op = do
ident <- parseOp fromOp
guard $ ident == op
opTable
:: [[(Qualified Ident, Associativity)]]
-> (a -> Maybe (Qualified Ident))
-> (Qualified Ident -> a -> a -> a)
-> [[P.Operator (Chain a) () Identity a]]
opTable ops fromOp reapply =
map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops
++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]]