{-# 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 = OpOrdering -> Op -> Op -> Maybe QORelation
forall a.
(Ord a, Eq a, Hashable a) =>
WQO a -> a -> a -> Maybe QORelation
getRelation OpOrdering
s Op
f Op
g Maybe QORelation -> Maybe QORelation -> Bool
forall a. Eq a => a -> a -> Bool
== QORelation -> Maybe QORelation
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 = OpOrdering -> Op -> Op -> Maybe QORelation
forall a.
(Ord a, Eq a, Hashable a) =>
WQO a -> a -> a -> Maybe QORelation
getRelation OpOrdering
s Op
f Op
g Maybe QORelation -> Maybe QORelation -> Bool
forall a. Eq a => a -> a -> Bool
== QORelation -> Maybe QORelation
forall a. a -> Maybe a
Just QORelation
QEQ
(>.) :: Op -> Op -> OpOrdering
>. :: Op -> Op -> OpOrdering
(>.) Op
f Op
g = Maybe OpOrdering -> OpOrdering
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe OpOrdering -> OpOrdering) -> Maybe OpOrdering -> OpOrdering
forall a b. (a -> b) -> a -> b
$ (Op, Op, QORelation) -> Maybe OpOrdering
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 = Maybe OpOrdering -> OpOrdering
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe OpOrdering -> OpOrdering) -> Maybe OpOrdering -> OpOrdering
forall a b. (a -> b) -> a -> b
$ (Op, Op, QORelation) -> Maybe OpOrdering
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 Parsec String () (Maybe OpOrdering)
-> String -> String -> Either ParseError (Maybe OpOrdering)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () (Maybe OpOrdering)
forall u. Parsec String u (Maybe OpOrdering)
parser String
"" String
str of
Left ParseError
err -> String -> Maybe OpOrdering
forall a. HasCallStack => String -> a
error (ParseError -> String
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 = ([Maybe OpOrdering] -> Maybe OpOrdering)
-> ParsecT String u Identity [Maybe OpOrdering]
-> ParsecT String u Identity (Maybe OpOrdering)
forall a b.
(a -> b)
-> ParsecT String u Identity a -> ParsecT String u Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe OpOrdering] -> Maybe OpOrdering
mergeAll' (ParsecT String u Identity (Maybe OpOrdering)
-> ParsecT String u Identity ()
-> ParsecT String u Identity [Maybe OpOrdering]
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 ParsecT String u Identity (Maybe OpOrdering)
forall u. Parsec String u (Maybe OpOrdering)
atom ParsecT String u Identity ()
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'' <- OpOrdering -> OpOrdering -> Maybe OpOrdering
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' (OpOrdering -> Maybe OpOrdering
forall a. a -> Maybe a
Just OpOrdering
x'' Maybe OpOrdering -> [Maybe OpOrdering] -> [Maybe OpOrdering]
forall a. a -> [a] -> [a]
: [Maybe OpOrdering]
xs)
mergeAll' [Maybe OpOrdering]
_ = Maybe OpOrdering
forall a. Maybe a
Nothing
conj :: ParsecT String u Identity ()
conj = ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String u Identity ()
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\8743' ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'^') ParsecT String u Identity Char
-> ParsecT String u Identity () -> ParsecT String u Identity ()
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
eq :: ParsecT String u Identity ()
eq = ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String u Identity ()
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=' ParsecT String u Identity Char
-> ParsecT String u Identity () -> ParsecT String u Identity ()
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
gt :: ParsecT String u Identity ()
gt = ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String u Identity ()
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>' ParsecT String u Identity Char
-> ParsecT String u Identity () -> ParsecT String u Identity ()
forall a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
atom :: ParsecT String u Identity (Maybe OpOrdering)
atom = ParsecT String u Identity (Maybe OpOrdering)
-> ParsecT String u Identity (Maybe OpOrdering)
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT String u Identity (Maybe OpOrdering)
forall u. Parsec String u (Maybe OpOrdering)
gtAtom ParsecT String u Identity (Maybe OpOrdering)
-> ParsecT String u Identity (Maybe OpOrdering)
-> ParsecT String u Identity (Maybe OpOrdering)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String u Identity (Maybe OpOrdering)
-> ParsecT String u Identity (Maybe OpOrdering)
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT String u Identity (Maybe OpOrdering)
forall u. Parsec String u (Maybe OpOrdering)
eqAtom
eqAtom :: ParsecT String u Identity (Maybe OpOrdering)
eqAtom = ([Op] -> Maybe OpOrdering)
-> ParsecT String u Identity [Op]
-> ParsecT String u Identity (Maybe OpOrdering)
forall a b.
(a -> b)
-> ParsecT String u Identity a -> ParsecT String u Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Op] -> Maybe OpOrdering
allEQ (ParsecT String u Identity Op
-> ParsecT String u Identity () -> ParsecT String u Identity [Op]
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 ParsecT String u Identity Op
forall {u}. ParsecT String u Identity Op
sym (ParsecT String u Identity () -> ParsecT String u Identity ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT String u Identity ()
forall {u}. ParsecT String u Identity ()
eq))
where
mkEQ :: a -> a -> Maybe (WQO a)
mkEQ a
f a
g = (a, a, QORelation) -> Maybe (WQO a)
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 = (Op -> Op -> Maybe OpOrdering)
-> [Op] -> [Op] -> [Maybe OpOrdering]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Op -> Op -> Maybe OpOrdering
forall {a}. (Ord a, Hashable a) => a -> a -> Maybe (WQO a)
mkEQ [Op]
syms ([Op] -> [Op]
forall a. HasCallStack => [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 <- ParsecT String u Identity Op
forall {u}. ParsecT String u Identity Op
sym
()
_ <- ParsecT String u Identity ()
forall {u}. ParsecT String u Identity ()
gt
Op
right <- ParsecT String u Identity Op
forall {u}. ParsecT String u Identity Op
sym
Maybe OpOrdering -> ParsecT String u Identity (Maybe OpOrdering)
forall a. a -> ParsecT String u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OpOrdering -> ParsecT String u Identity (Maybe OpOrdering))
-> Maybe OpOrdering -> ParsecT String u Identity (Maybe OpOrdering)
forall a b. (a -> b) -> a -> b
$ (Op, Op, QORelation) -> Maybe OpOrdering
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 = (String -> Op)
-> ParsecT String u Identity String -> ParsecT String u Identity Op
forall a b.
(a -> b)
-> ParsecT String u Identity a -> ParsecT String u Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Op
Op (Text -> Op) -> (String -> Text) -> String -> Op
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+' ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'*'))