phino-0.0.147: src/Condition.hs

{-# 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 {message :: String}
  deriving (Exception)

instance Show ConditionException where
  show CouldNotParseCondition{..} = printf "Couldn't parse given condition, cause: %s" message

type Parser = Parsec Void String

whiteSpace :: Parser ()
whiteSpace = L.space hspace1 empty empty

lexeme :: Parser a -> Parser a
lexeme = L.lexeme whiteSpace

symbol :: String -> Parser String
symbol = L.symbol whiteSpace

lparen :: Parser String
lparen = symbol "("

rparen :: Parser String
rparen = symbol ")"

comma :: Parser String
comma = symbol ","

several :: Parser a -> Parser [a]
several item = choice [try (between (symbol "[") (symbol "]") (item `sepBy1` comma)), pure <$> item]

number :: Parser Y.Number
number =
  choice
    [ do
        _ <- symbol "length" >> lparen
        bd <- _binding phiParser
        _ <- rparen
        return (Y.Length bd)
    , do
        _ <- symbol "domain" >> lparen
        bd <- _binding phiParser
        _ <- rparen
        return (Y.Domain bd)
    , either Y.AnyIndex Y.MetaIndex <$> _index phiParser
    , do
        sign <- optional (choice [char '-', char '+'])
        unsigned <- lexeme L.decimal
        let signed = if sign == Just '-' then negate unsigned else unsigned :: Integer
        if signed < toInteger (minBound :: Int) || signed > toInteger (maxBound :: Int)
          then fail (printf "the literal %d does not fit into Int" signed)
          else return (Y.Literal (fromInteger signed))
    ]

comparable :: Parser Y.Comparable
comparable =
  choice
    [ try $ Y.CmpNum <$> number
    , try $ Y.CmpAttr <$> _attribute phiParser
    , Y.CmpExpr <$> _expression phiParser
    ]

condition :: Parser Y.Condition
condition =
  choice
    [ do
        _ <- symbol "and" >> lparen
        args <- condition `sepBy1` comma
        _ <- rparen
        return (Y.And args)
    , do
        _ <- symbol "or" >> lparen
        args <- condition `sepBy1` comma
        _ <- rparen
        return (Y.Or args)
    , do
        _ <- symbol "in" >> lparen
        attrs <- several (choice [AtLambda <$ symbol "λ", AtDelta <$ symbol "Δ", _attribute phiParser])
        _ <- comma
        bds <- several (_binding phiParser)
        _ <- rparen
        return (Y.In attrs bds)
    , do
        _ <- symbol "not" >> lparen
        cond <- condition
        _ <- rparen
        return (Y.Not cond)
    , do
        _ <- symbol "eq" >> lparen
        left <- comparable
        _ <- comma
        right <- comparable
        _ <- rparen
        return (Y.Eq left right)
    , do
        _ <- symbol "gt" >> lparen
        left <- comparable
        _ <- comma
        right <- comparable
        _ <- rparen
        return (Y.Gt left right)
    , do
        _ <- symbol "nf" >> lparen
        expr <- _expression phiParser
        _ <- rparen
        return (Y.NF expr)
    , do
        _ <- symbol "absolute" >> lparen
        expr <- _expression phiParser
        _ <- rparen
        return (Y.Absolute expr)
    , do
        _ <- symbol "matches" >> lparen
        ptn <- _string phiParser
        _ <- comma
        expr <- _expression phiParser
        _ <- rparen
        return (Y.Matches ptn expr)
    , do
        _ <- symbol "part-of" >> lparen
        expr <- _expression phiParser
        _ <- comma
        bd <- _binding phiParser
        _ <- rparen
        return (Y.PartOf expr bd)
    , do
        _ <- symbol "formation" >> lparen
        expr <- _expression phiParser
        _ <- rparen
        return (Y.IsFormation expr)
    ]

parseCondition :: String -> Either String Y.Condition
parseCondition input = do
  let parsed =
        runParser
          ( do
              _ <- whiteSpace
              p <- condition
              _ <- eof
              return p
          )
          "condition"
          input
  case parsed of
    Right parsed' -> Right parsed'
    Left err -> Left (errorBundlePretty err)

parseConditionThrows :: String -> IO Y.Condition
parseConditionThrows cnd = orThrow CouldNotParseCondition (parseCondition cnd)