{-# 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 = 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 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 = 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

-- |  @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 = 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)

-- |  @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 = 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)

-- |  @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 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
'*'))