{-# LANGUAGE FlexibleInstances #-}
module Language.REST.Internal.OpOrdering (
empty
, OpOrdering
, opGT
, opEQ
, (=.)
, (>.)
, (<.)
, parseOO
) where
import Prelude hiding (GT, EQ)
import Data.Maybe
import qualified Data.Text as T
import Text.ParserCombinators.Parsec.Char
import Text.ParserCombinators.Parsec
import Text.Parsec (Parsec)
import Language.REST.Op
import Language.REST.Internal.WQO as WQO
type OpOrdering = WQO Op
opGT :: OpOrdering -> Op -> Op -> Bool
opGT :: OpOrdering -> Op -> Op -> Bool
opGT OpOrdering
s Op
f Op
g = forall a.
(Ord a, Eq a, Hashable a) =>
WQO a -> a -> a -> Maybe QORelation
getRelation OpOrdering
s Op
f Op
g forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just QORelation
QGT
opEQ :: OpOrdering -> Op -> Op -> Bool
opEQ :: OpOrdering -> Op -> Op -> Bool
opEQ OpOrdering
s Op
f Op
g = forall a.
(Ord a, Eq a, Hashable a) =>
WQO a -> a -> a -> Maybe QORelation
getRelation OpOrdering
s Op
f Op
g forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just QORelation
QEQ
(>.) :: Op -> Op -> OpOrdering
>. :: Op -> Op -> OpOrdering
(>.) Op
f Op
g = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a.
(Ord a, Eq a, Hashable a) =>
(a, a, QORelation) -> Maybe (WQO a)
WQO.singleton (Op
f, Op
g, QORelation
QGT)
(=.) :: Op -> Op -> OpOrdering
=. :: Op -> Op -> OpOrdering
(=.) Op
f Op
g = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a.
(Ord a, Eq a, Hashable a) =>
(a, a, QORelation) -> Maybe (WQO a)
WQO.singleton (Op
f, Op
g, QORelation
QEQ)
(<.) :: Op -> Op -> OpOrdering
<. :: Op -> Op -> OpOrdering
(<.) Op
f Op
g = Op
g Op -> Op -> OpOrdering
>. Op
f
parseOO :: String -> Maybe OpOrdering
parseOO :: String -> Maybe OpOrdering
parseOO String
str =
case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse forall u. Parsec String u (Maybe OpOrdering)
parser String
"" String
str of
Left ParseError
err -> forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show ParseError
err)
Right Maybe OpOrdering
t -> Maybe OpOrdering
t
parser :: Parsec String u (Maybe OpOrdering)
parser :: forall u. Parsec String u (Maybe OpOrdering)
parser = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe OpOrdering] -> Maybe OpOrdering
mergeAll' (forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy1 forall u. Parsec String u (Maybe OpOrdering)
atom forall {u}. ParsecT String u Identity ()
conj) where
mergeAll' :: [Maybe OpOrdering] -> Maybe OpOrdering
mergeAll' :: [Maybe OpOrdering] -> Maybe OpOrdering
mergeAll' [Maybe OpOrdering
x] = Maybe OpOrdering
x
mergeAll' (Just OpOrdering
x : Just OpOrdering
x' : [Maybe OpOrdering]
xs) =
do
OpOrdering
x'' <- forall a.
(Ord a, Eq a, Hashable a) =>
WQO a -> WQO a -> Maybe (WQO a)
merge OpOrdering
x OpOrdering
x'
[Maybe OpOrdering] -> Maybe OpOrdering
mergeAll' (forall a. a -> Maybe a
Just OpOrdering
x'' forall a. a -> [a] -> [a]
: [Maybe OpOrdering]
xs)
mergeAll' [Maybe OpOrdering]
_ = forall a. Maybe a
Nothing
conj :: ParsecT String u Identity ()
conj = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\8743' forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'^') forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
eq :: ParsecT String u Identity ()
eq = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
gt :: ParsecT String u Identity ()
gt = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
atom :: ParsecT String u Identity (Maybe OpOrdering)
atom = forall tok st a. GenParser tok st a -> GenParser tok st a
try forall u. Parsec String u (Maybe OpOrdering)
gtAtom forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall tok st a. GenParser tok st a -> GenParser tok st a
try forall u. Parsec String u (Maybe OpOrdering)
eqAtom
eqAtom :: ParsecT String u Identity (Maybe OpOrdering)
eqAtom = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Op] -> Maybe OpOrdering
allEQ (forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy1 forall {u}. ParsecT String u Identity Op
sym (forall tok st a. GenParser tok st a -> GenParser tok st a
try forall {u}. ParsecT String u Identity ()
eq))
where
mkEQ :: a -> a -> Maybe (WQO a)
mkEQ a
f a
g = forall a.
(Ord a, Eq a, Hashable a) =>
(a, a, QORelation) -> Maybe (WQO a)
WQO.singleton (a
f, a
g, QORelation
QEQ)
allEQ :: [Op] -> Maybe OpOrdering
allEQ [Op]
syms =
let
pairs :: [Maybe OpOrdering]
pairs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. (Ord a, Hashable a) => a -> a -> Maybe (WQO a)
mkEQ [Op]
syms (forall a. [a] -> [a]
tail [Op]
syms)
in
[Maybe OpOrdering] -> Maybe OpOrdering
mergeAll' [Maybe OpOrdering]
pairs
gtAtom :: ParsecT String u Identity (Maybe OpOrdering)
gtAtom = do
Op
left <- forall {u}. ParsecT String u Identity Op
sym
()
_ <- forall {u}. ParsecT String u Identity ()
gt
Op
right <- forall {u}. ParsecT String u Identity Op
sym
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
(Ord a, Eq a, Hashable a) =>
(a, a, QORelation) -> Maybe (WQO a)
WQO.singleton (Op
left, Op
right, QORelation
QGT)
sym :: ParsecT String u Identity Op
sym = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Op
Op forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+' forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'*'))