{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}

-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

module Condition (parseCondition, parseConditionThrows) where

import AST (Attribute (AtDelta, AtLambda))
import Control.Exception (Exception)
import Data.Void (Void)
import Misc (orThrow)
import Parser (PhiParser (..), phiParser)
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Printf (printf)
import qualified Yaml as Y

newtype ConditionException = CouldNotParseCondition {ConditionException -> [Char]
message :: String}
  deriving (Show ConditionException
Typeable ConditionException
(Typeable ConditionException, Show ConditionException) =>
(ConditionException -> SomeException)
-> (SomeException -> Maybe ConditionException)
-> (ConditionException -> [Char])
-> Exception ConditionException
SomeException -> Maybe ConditionException
ConditionException -> [Char]
ConditionException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> [Char]) -> Exception e
$ctoException :: ConditionException -> SomeException
toException :: ConditionException -> SomeException
$cfromException :: SomeException -> Maybe ConditionException
fromException :: SomeException -> Maybe ConditionException
$cdisplayException :: ConditionException -> [Char]
displayException :: ConditionException -> [Char]
Exception)

instance Show ConditionException where
  show :: ConditionException -> [Char]
show CouldNotParseCondition{[Char]
message :: ConditionException -> [Char]
message :: [Char]
..} = [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"Couldn't parse given condition, cause: %s" [Char]
message

type Parser = Parsec Void String

whiteSpace :: Parser ()
whiteSpace :: Parser ()
whiteSpace = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace1 Parser ()
forall a. ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a
empty Parser ()
forall a. ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a
empty

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = Parser ()
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
whiteSpace

symbol :: String -> Parser String
symbol :: [Char] -> Parser [Char]
symbol = Parser ()
-> Tokens [Char] -> ParsecT Void [Char] Identity (Tokens [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
whiteSpace

lparen :: Parser String
lparen :: Parser [Char]
lparen = [Char] -> Parser [Char]
symbol [Char]
"("

rparen :: Parser String
rparen :: Parser [Char]
rparen = [Char] -> Parser [Char]
symbol [Char]
")"

comma :: Parser String
comma :: Parser [Char]
comma = [Char] -> Parser [Char]
symbol [Char]
","

several :: Parser a -> Parser [a]
several :: forall a. Parser a -> Parser [a]
several Parser a
item = [ParsecT Void [Char] Identity [a]]
-> ParsecT Void [Char] Identity [a]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParsecT Void [Char] Identity [a]
-> ParsecT Void [Char] Identity [a]
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser [Char]
-> Parser [Char]
-> ParsecT Void [Char] Identity [a]
-> ParsecT Void [Char] Identity [a]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ([Char] -> Parser [Char]
symbol [Char]
"[") ([Char] -> Parser [Char]
symbol [Char]
"]") (Parser a
item Parser a -> Parser [Char] -> ParsecT Void [Char] Identity [a]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` Parser [Char]
comma)), a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> [a]) -> Parser a -> ParsecT Void [Char] Identity [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
item]

number :: Parser Y.Number
number :: Parser Number
number =
  [Parser Number] -> Parser Number
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"length" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        Binding
bd <- PhiParser -> Parsec Void [Char] Binding
_binding PhiParser
phiParser
        [Char]
_ <- Parser [Char]
rparen
        Number -> Parser Number
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Binding -> Number
Y.Length Binding
bd)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"domain" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        Binding
bd <- PhiParser -> Parsec Void [Char] Binding
_binding PhiParser
phiParser
        [Char]
_ <- Parser [Char]
rparen
        Number -> Parser Number
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Binding -> Number
Y.Domain Binding
bd)
    , (Slot -> Number) -> (Text -> Number) -> Either Slot Text -> Number
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Slot -> Number
Y.AnyIndex Text -> Number
Y.MetaIndex (Either Slot Text -> Number)
-> ParsecT Void [Char] Identity (Either Slot Text) -> Parser Number
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhiParser -> ParsecT Void [Char] Identity (Either Slot Text)
_index PhiParser
phiParser
    , do
        Maybe Char
sign <- ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([ParsecT Void [Char] Identity Char]
-> ParsecT Void [Char] Identity Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Token [Char] -> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token [Char]
'-', Token [Char] -> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token [Char]
'+'])
        Integer
unsigned <- Parser Integer -> Parser Integer
forall a. Parser a -> Parser a
lexeme Parser Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
        let signed :: Integer
signed = if Maybe Char
sign Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'-' then Integer -> Integer
forall a. Num a => a -> a
negate Integer
unsigned else Integer
unsigned :: Integer
        if Integer
signed Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
minBound :: Int) Bool -> Bool -> Bool
|| Integer
signed Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int)
          then [Char] -> Parser Number
forall a. [Char] -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Integer -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"the literal %d does not fit into Int" Integer
signed)
          else Number -> Parser Number
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Number
Y.Literal (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
signed))
    ]

comparable :: Parser Y.Comparable
comparable :: Parser Comparable
comparable =
  [Parser Comparable] -> Parser Comparable
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parser Comparable -> Parser Comparable
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Comparable -> Parser Comparable)
-> Parser Comparable -> Parser Comparable
forall a b. (a -> b) -> a -> b
$ Number -> Comparable
Y.CmpNum (Number -> Comparable) -> Parser Number -> Parser Comparable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Number
number
    , Parser Comparable -> Parser Comparable
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Comparable -> Parser Comparable)
-> Parser Comparable -> Parser Comparable
forall a b. (a -> b) -> a -> b
$ Attribute -> Comparable
Y.CmpAttr (Attribute -> Comparable)
-> ParsecT Void [Char] Identity Attribute -> Parser Comparable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhiParser -> ParsecT Void [Char] Identity Attribute
_attribute PhiParser
phiParser
    , Expression -> Comparable
Y.CmpExpr (Expression -> Comparable)
-> ParsecT Void [Char] Identity Expression -> Parser Comparable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhiParser -> ParsecT Void [Char] Identity Expression
_expression PhiParser
phiParser
    ]

condition :: Parser Y.Condition
condition :: Parser Condition
condition =
  [Parser Condition] -> Parser Condition
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"and" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        [Condition]
args <- Parser Condition
condition Parser Condition
-> Parser [Char] -> ParsecT Void [Char] Identity [Condition]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` Parser [Char]
comma
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Condition] -> Condition
Y.And [Condition]
args)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"or" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        [Condition]
args <- Parser Condition
condition Parser Condition
-> Parser [Char] -> ParsecT Void [Char] Identity [Condition]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` Parser [Char]
comma
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Condition] -> Condition
Y.Or [Condition]
args)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"in" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        [Attribute]
attrs <- ParsecT Void [Char] Identity Attribute -> Parser [Attribute]
forall a. Parser a -> Parser [a]
several ([ParsecT Void [Char] Identity Attribute]
-> ParsecT Void [Char] Identity Attribute
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Attribute
AtLambda Attribute
-> Parser [Char] -> ParsecT Void [Char] Identity Attribute
forall a b.
a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
symbol [Char]
"λ", Attribute
AtDelta Attribute
-> Parser [Char] -> ParsecT Void [Char] Identity Attribute
forall a b.
a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
symbol [Char]
"Δ", PhiParser -> ParsecT Void [Char] Identity Attribute
_attribute PhiParser
phiParser])
        [Char]
_ <- Parser [Char]
comma
        [Binding]
bds <- Parsec Void [Char] Binding -> Parser [Binding]
forall a. Parser a -> Parser [a]
several (PhiParser -> Parsec Void [Char] Binding
_binding PhiParser
phiParser)
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Attribute] -> [Binding] -> Condition
Y.In [Attribute]
attrs [Binding]
bds)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"not" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        Condition
cond <- Parser Condition
condition
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Condition -> Condition
Y.Not Condition
cond)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"eq" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        Comparable
left <- Parser Comparable
comparable
        [Char]
_ <- Parser [Char]
comma
        Comparable
right <- Parser Comparable
comparable
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Comparable -> Comparable -> Condition
Y.Eq Comparable
left Comparable
right)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"gt" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        Comparable
left <- Parser Comparable
comparable
        [Char]
_ <- Parser [Char]
comma
        Comparable
right <- Parser Comparable
comparable
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Comparable -> Comparable -> Condition
Y.Gt Comparable
left Comparable
right)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"nf" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        Expression
expr <- PhiParser -> ParsecT Void [Char] Identity Expression
_expression PhiParser
phiParser
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Condition
Y.NF Expression
expr)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"absolute" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        Expression
expr <- PhiParser -> ParsecT Void [Char] Identity Expression
_expression PhiParser
phiParser
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Condition
Y.Absolute Expression
expr)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"matches" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        [Char]
ptn <- PhiParser -> Parser [Char]
_string PhiParser
phiParser
        [Char]
_ <- Parser [Char]
comma
        Expression
expr <- PhiParser -> ParsecT Void [Char] Identity Expression
_expression PhiParser
phiParser
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Expression -> Condition
Y.Matches [Char]
ptn Expression
expr)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"part-of" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        Expression
expr <- PhiParser -> ParsecT Void [Char] Identity Expression
_expression PhiParser
phiParser
        [Char]
_ <- Parser [Char]
comma
        Binding
bd <- PhiParser -> Parsec Void [Char] Binding
_binding PhiParser
phiParser
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Binding -> Condition
Y.PartOf Expression
expr Binding
bd)
    , do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"formation" Parser [Char] -> Parser [Char] -> Parser [Char]
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser [Char]
lparen
        Expression
expr <- PhiParser -> ParsecT Void [Char] Identity Expression
_expression PhiParser
phiParser
        [Char]
_ <- Parser [Char]
rparen
        Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Condition
Y.IsFormation Expression
expr)
    ]

parseCondition :: String -> Either String Y.Condition
parseCondition :: [Char] -> Either [Char] Condition
parseCondition [Char]
input = do
  let parsed :: Either (ParseErrorBundle [Char] Void) Condition
parsed =
        Parser Condition
-> [Char]
-> [Char]
-> Either (ParseErrorBundle [Char] Void) Condition
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
runParser
          ( do
              ()
_ <- Parser ()
whiteSpace
              Condition
p <- Parser Condition
condition
              ()
_ <- Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
              Condition -> Parser Condition
forall a. a -> ParsecT Void [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Condition
p
          )
          [Char]
"condition"
          [Char]
input
  case Either (ParseErrorBundle [Char] Void) Condition
parsed of
    Right Condition
parsed' -> Condition -> Either [Char] Condition
forall a b. b -> Either a b
Right Condition
parsed'
    Left ParseErrorBundle [Char] Void
err -> [Char] -> Either [Char] Condition
forall a b. a -> Either a b
Left (ParseErrorBundle [Char] Void -> [Char]
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty ParseErrorBundle [Char] Void
err)

parseConditionThrows :: String -> IO Y.Condition
parseConditionThrows :: [Char] -> IO Condition
parseConditionThrows [Char]
cnd = ([Char] -> ConditionException)
-> Either [Char] Condition -> IO Condition
forall e a. Exception e => ([Char] -> e) -> Either [Char] a -> IO a
orThrow [Char] -> ConditionException
CouldNotParseCondition ([Char] -> Either [Char] Condition
parseCondition [Char]
cnd)