{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module MSU.Match
    ( Match(..)
    , matches
    , matchesMaybe
    )
where

import Control.Applicative ((<|>))
import Data.Aeson
import Data.Maybe (fromMaybe)

data Match a
    = Any
    -- ^ Always matches
    | Eq a
    -- ^ Matches if equal
    | In [a]
    -- ^ Matches if element

instance FromJSON a => FromJSON (Match a) where
    parseJSON :: Value -> Parser (Match a)
parseJSON = String -> (Object -> Parser (Match a)) -> Value -> Parser (Match a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"match operator" ((Object -> Parser (Match a)) -> Value -> Parser (Match a))
-> (Object -> Parser (Match a)) -> Value -> Parser (Match a)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        Maybe a
mEq <- Object
o Object -> Key -> Parser (Maybe a)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"eq"
        Maybe [a]
mIn <- Object
o Object -> Key -> Parser (Maybe [a])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"in"
        Match a -> Parser (Match a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match a -> Parser (Match a)) -> Match a -> Parser (Match a)
forall a b. (a -> b) -> a -> b
$ Match a -> Maybe (Match a) -> Match a
forall a. a -> Maybe a -> a
fromMaybe Match a
forall a. Match a
Any (Maybe (Match a) -> Match a) -> Maybe (Match a) -> Match a
forall a b. (a -> b) -> a -> b
$ (a -> Match a
forall a. a -> Match a
Eq (a -> Match a) -> Maybe a -> Maybe (Match a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
mEq) Maybe (Match a) -> Maybe (Match a) -> Maybe (Match a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([a] -> Match a
forall a. [a] -> Match a
In ([a] -> Match a) -> Maybe [a] -> Maybe (Match a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [a]
mIn)

instance ToJSON a => ToJSON (Match a) where
    toJSON :: Match a -> Value
toJSON = \case
        Match a
Any -> Value
Null
        Eq a
a -> [Pair] -> Value
object [Key
"eq" Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
a]
        In [a]
as -> [Pair] -> Value
object [Key
"in" Key -> [a] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [a]
as]

-- | Apply a @'Match'@ to get @'Bool'@
--
-- Accepts @'Maybe'@ purefuly for convenience of current use (where matches are
-- optional keys in JSON).
--
matches :: Eq a => Maybe (Match a) -> a -> Bool
matches :: Maybe (Match a) -> a -> Bool
matches = Match a -> a -> Bool
forall a. Eq a => Match a -> a -> Bool
matchFn (Match a -> a -> Bool)
-> (Maybe (Match a) -> Match a) -> Maybe (Match a) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match a -> Maybe (Match a) -> Match a
forall a. a -> Maybe a -> a
fromMaybe Match a
forall a. Match a
Any

-- | Apply a @'Match'@ to a @'Maybe'@ to get @'Bool'@
--
-- A @'Nothing'@ always matches.
--
matchesMaybe :: Eq a => Maybe (Match a) -> Maybe a -> Bool
matchesMaybe :: Maybe (Match a) -> Maybe a -> Bool
matchesMaybe Maybe (Match a)
mm = Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Maybe (Match a)
mm Maybe (Match a) -> a -> Bool
forall a. Eq a => Maybe (Match a) -> a -> Bool
`matches`)

matchFn :: Eq a => Match a -> a -> Bool
matchFn :: Match a -> a -> Bool
matchFn = \case
    Match a
Any -> Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True
    Eq a
a -> (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a)
    In [a]
as -> (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
as)