{-# LANGUAGE FlexibleInstances #-}


-- | This module defines an interface for 'WQO's on 'Op'erators,
--   for example, that are used as the precedence for an [RPQO]("Language.REST.RPO").
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 o f g@ returns @true@ if @f > g@ in @o@
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 o f g@ returns @true@ if @f = g@ in @o@
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

-- |  @f >. g@ generates a new ordering with @f@ greater than @g@.
--   This function is undefined if f == g.
(>.) :: 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)

-- |  @f =. g@ generates a new ordering with @f@ equal to @g@.
--   This function is undefined if f == g.
(=.) :: 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)

-- |  @f <. g@ generates a new ordering with @f@ less than @g@.
--   This function is undefined if f == g.
(<.) :: Op -> Op -> OpOrdering
<. :: Op -> Op -> OpOrdering
(<.) Op
f Op
g = Op
g Op -> Op -> OpOrdering
>. Op
f

-- | @parseOO str@ returns the ordering defined by @str@. If the input describes
--   /any/ ordering, (i.e "f = f"), then this function returns 'Nothing'.
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
'*'))