{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

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

module Yaml where

import Ast
import Control.Applicative (asum)
import Data.Aeson
import qualified Data.ByteString as BS
import Data.FileEmbed (embedDir)
import Data.Text (unpack)
import Data.Yaml (Parser)
import qualified Data.Yaml as Yaml
import GHC.Generics
import Misc (allPathsIn)
import Parser

parseJSON' :: String -> (String -> Either String a) -> Value -> Parser a
parseJSON' :: forall a.
[Char] -> ([Char] -> Either [Char] a) -> Value -> Parser a
parseJSON' [Char]
name [Char] -> Either [Char] a
func =
  [Char] -> (Text -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText
    [Char]
name
    ( \Text
txt -> case [Char] -> Either [Char] a
func (Text -> [Char]
unpack Text
txt) of
        Left [Char]
err -> [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
        Right a
parsed -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
parsed
    )

instance FromJSON Expression where
  parseJSON :: Value -> Parser Expression
parseJSON = [Char]
-> ([Char] -> Either [Char] Expression)
-> Value
-> Parser Expression
forall a.
[Char] -> ([Char] -> Either [Char] a) -> Value -> Parser a
parseJSON' [Char]
"Expression" [Char] -> Either [Char] Expression
parseExpression

instance FromJSON Attribute where
  parseJSON :: Value -> Parser Attribute
parseJSON =
    [Char] -> (Text -> Parser Attribute) -> Value -> Parser Attribute
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText
      [Char]
"Attribute"
      ( \Text
txt -> case Text -> [Char]
unpack Text
txt of
          [Char]
"λ" -> Attribute -> Parser Attribute
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
AtLambda
          [Char]
"Δ" -> Attribute -> Parser Attribute
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
AtDelta
          [Char]
other -> case [Char] -> Either [Char] Attribute
parseAttribute [Char]
other of
            Left [Char]
err -> [Char] -> Parser Attribute
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
            Right Attribute
attr -> Attribute -> Parser Attribute
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
attr
      )

instance FromJSON Binding where
  parseJSON :: Value -> Parser Binding
parseJSON = [Char]
-> ([Char] -> Either [Char] Binding) -> Value -> Parser Binding
forall a.
[Char] -> ([Char] -> Either [Char] a) -> Value -> Parser a
parseJSON' [Char]
"Binding" [Char] -> Either [Char] Binding
parseBinding

instance FromJSON Number where
  parseJSON :: Value -> Parser Number
parseJSON Value
v = case Value
v of
    Object Object
o ->
      [Parser Number] -> Parser Number
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ Attribute -> Number
Ordinal (Attribute -> Number) -> Parser Attribute -> Parser Number
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Attribute
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ordinal",
          Binding -> Number
Length (Binding -> Number) -> Parser Binding -> Parser Number
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Binding
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"length"
        ]
    Number Scientific
num -> Number -> Parser Number
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Number
Literal (Scientific -> Integer
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
num))
    Value
_ ->
      [Char] -> Parser Number
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Expected a numerable expression (object or number)"

instance FromJSON Comparable where
  parseJSON :: Value -> Parser Comparable
parseJSON Value
v =
    [Parser Comparable] -> Parser Comparable
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ Attribute -> Comparable
CmpAttr (Attribute -> Comparable) -> Parser Attribute -> Parser Comparable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Attribute
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v,
        Number -> Comparable
CmpNum (Number -> Comparable) -> Parser Number -> Parser Comparable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Number
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
      ]

instance FromJSON Condition where
  parseJSON :: Value -> Parser Condition
parseJSON =
    [Char] -> (Object -> Parser Condition) -> Value -> Parser Condition
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject
      [Char]
"Condition"
      ( \Object
v ->
          [Parser Condition] -> Parser Condition
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
            [ [Condition] -> Condition
And ([Condition] -> Condition)
-> Parser [Condition] -> Parser Condition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser [Condition]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"and",
              [Condition] -> Condition
Or ([Condition] -> Condition)
-> Parser [Condition] -> Parser Condition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser [Condition]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"or",
              Condition -> Condition
Not (Condition -> Condition) -> Parser Condition -> Parser Condition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Condition
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"not",
              Attribute -> Condition
Alpha (Attribute -> Condition) -> Parser Attribute -> Parser Condition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Attribute
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"alpha",
              Expression -> Condition
NF (Expression -> Condition) -> Parser Expression -> Parser Condition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"nf",
              Expression -> Condition
XI (Expression -> Condition) -> Parser Expression -> Parser Condition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"xi",
              do
                [Value]
vals <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"eq"
                case [Value]
vals of
                  [Value
left_, Value
right_] -> Comparable -> Comparable -> Condition
Eq (Comparable -> Comparable -> Condition)
-> Parser Comparable -> Parser (Comparable -> Condition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Comparable
forall a. FromJSON a => Value -> Parser a
parseJSON Value
left_ Parser (Comparable -> Condition)
-> Parser Comparable -> Parser Condition
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Comparable
forall a. FromJSON a => Value -> Parser a
parseJSON Value
right_
                  [Value]
_ -> [Char] -> Parser Condition
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"'eq' must contain exactly two elements",
              do
                [Value]
vals <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"in"
                case [Value]
vals of
                  [Value
attr_, Value
binding_] -> do
                    Attribute
attr <- Value -> Parser Attribute
forall a. FromJSON a => Value -> Parser a
parseJSON Value
attr_
                    Binding
bd <- Value -> Parser Binding
forall a. FromJSON a => Value -> Parser a
parseJSON Value
binding_
                    Condition -> Parser Condition
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Binding -> Condition
In Attribute
attr Binding
bd)
                  [Value]
_ -> [Char] -> Parser Condition
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"'in' must contain exactly two elements"
            ]
      )

instance FromJSON Extra where
  parseJSON :: Value -> Parser Extra
parseJSON = Options -> Value -> Parser Extra
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions

instance FromJSON Rule where
  parseJSON :: Value -> Parser Rule
parseJSON =
    Options -> Value -> Parser Rule
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON
      Options
defaultOptions
        { fieldLabelModifier = \case
            [Char]
"where_" -> [Char]
"where"
            [Char]
other -> [Char]
other
        }

data Number
  = Ordinal Attribute
  | Length Binding
  | Literal Integer
  deriving ((forall x. Number -> Rep Number x)
-> (forall x. Rep Number x -> Number) -> Generic Number
forall x. Rep Number x -> Number
forall x. Number -> Rep Number x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Number -> Rep Number x
from :: forall x. Number -> Rep Number x
$cto :: forall x. Rep Number x -> Number
to :: forall x. Rep Number x -> Number
Generic, Int -> Number -> [Char] -> [Char]
[Number] -> [Char] -> [Char]
Number -> [Char]
(Int -> Number -> [Char] -> [Char])
-> (Number -> [Char])
-> ([Number] -> [Char] -> [Char])
-> Show Number
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Number -> [Char] -> [Char]
showsPrec :: Int -> Number -> [Char] -> [Char]
$cshow :: Number -> [Char]
show :: Number -> [Char]
$cshowList :: [Number] -> [Char] -> [Char]
showList :: [Number] -> [Char] -> [Char]
Show)

data Comparable
  = CmpAttr Attribute
  | CmpNum Number
  deriving ((forall x. Comparable -> Rep Comparable x)
-> (forall x. Rep Comparable x -> Comparable) -> Generic Comparable
forall x. Rep Comparable x -> Comparable
forall x. Comparable -> Rep Comparable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Comparable -> Rep Comparable x
from :: forall x. Comparable -> Rep Comparable x
$cto :: forall x. Rep Comparable x -> Comparable
to :: forall x. Rep Comparable x -> Comparable
Generic, Int -> Comparable -> [Char] -> [Char]
[Comparable] -> [Char] -> [Char]
Comparable -> [Char]
(Int -> Comparable -> [Char] -> [Char])
-> (Comparable -> [Char])
-> ([Comparable] -> [Char] -> [Char])
-> Show Comparable
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Comparable -> [Char] -> [Char]
showsPrec :: Int -> Comparable -> [Char] -> [Char]
$cshow :: Comparable -> [Char]
show :: Comparable -> [Char]
$cshowList :: [Comparable] -> [Char] -> [Char]
showList :: [Comparable] -> [Char] -> [Char]
Show)

data Condition
  = And [Condition]
  | Or [Condition]
  | In Attribute Binding
  | Not Condition
  | Alpha Attribute
  | Eq Comparable Comparable
  | NF Expression
  | XI Expression
  deriving ((forall x. Condition -> Rep Condition x)
-> (forall x. Rep Condition x -> Condition) -> Generic Condition
forall x. Rep Condition x -> Condition
forall x. Condition -> Rep Condition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Condition -> Rep Condition x
from :: forall x. Condition -> Rep Condition x
$cto :: forall x. Rep Condition x -> Condition
to :: forall x. Rep Condition x -> Condition
Generic, Int -> Condition -> [Char] -> [Char]
[Condition] -> [Char] -> [Char]
Condition -> [Char]
(Int -> Condition -> [Char] -> [Char])
-> (Condition -> [Char])
-> ([Condition] -> [Char] -> [Char])
-> Show Condition
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Condition -> [Char] -> [Char]
showsPrec :: Int -> Condition -> [Char] -> [Char]
$cshow :: Condition -> [Char]
show :: Condition -> [Char]
$cshowList :: [Condition] -> [Char] -> [Char]
showList :: [Condition] -> [Char] -> [Char]
Show)

data Extra = Extra
  { Extra -> Expression
meta :: Expression,
    Extra -> [Char]
function :: String,
    Extra -> [Expression]
args :: [Expression]
  }
  deriving ((forall x. Extra -> Rep Extra x)
-> (forall x. Rep Extra x -> Extra) -> Generic Extra
forall x. Rep Extra x -> Extra
forall x. Extra -> Rep Extra x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Extra -> Rep Extra x
from :: forall x. Extra -> Rep Extra x
$cto :: forall x. Rep Extra x -> Extra
to :: forall x. Rep Extra x -> Extra
Generic, Int -> Extra -> [Char] -> [Char]
[Extra] -> [Char] -> [Char]
Extra -> [Char]
(Int -> Extra -> [Char] -> [Char])
-> (Extra -> [Char]) -> ([Extra] -> [Char] -> [Char]) -> Show Extra
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Extra -> [Char] -> [Char]
showsPrec :: Int -> Extra -> [Char] -> [Char]
$cshow :: Extra -> [Char]
show :: Extra -> [Char]
$cshowList :: [Extra] -> [Char] -> [Char]
showList :: [Extra] -> [Char] -> [Char]
Show)

data Rule = Rule
  { Rule -> Maybe [Char]
name :: Maybe String,
    Rule -> Expression
pattern :: Expression,
    Rule -> Expression
result :: Expression,
    Rule -> Maybe Condition
when :: Maybe Condition,
    Rule -> Maybe [Extra]
where_ :: Maybe [Extra]
  }
  deriving ((forall x. Rule -> Rep Rule x)
-> (forall x. Rep Rule x -> Rule) -> Generic Rule
forall x. Rep Rule x -> Rule
forall x. Rule -> Rep Rule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Rule -> Rep Rule x
from :: forall x. Rule -> Rep Rule x
$cto :: forall x. Rep Rule x -> Rule
to :: forall x. Rep Rule x -> Rule
Generic, Int -> Rule -> [Char] -> [Char]
[Rule] -> [Char] -> [Char]
Rule -> [Char]
(Int -> Rule -> [Char] -> [Char])
-> (Rule -> [Char]) -> ([Rule] -> [Char] -> [Char]) -> Show Rule
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Rule -> [Char] -> [Char]
showsPrec :: Int -> Rule -> [Char] -> [Char]
$cshow :: Rule -> [Char]
show :: Rule -> [Char]
$cshowList :: [Rule] -> [Char] -> [Char]
showList :: [Rule] -> [Char] -> [Char]
Show)

normalizationRules :: [Rule]
{-# NOINLINE normalizationRules #-}
normalizationRules :: [Rule]
normalizationRules = (([Char], ByteString) -> Rule) -> [([Char], ByteString)] -> [Rule]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], ByteString) -> Rule
decodeRule $(embedDir "resources")
  where
    decodeRule :: (FilePath, BS.ByteString) -> Rule
    decodeRule :: ([Char], ByteString) -> Rule
decodeRule ([Char]
path, ByteString
bs) =
      case ByteString -> Either ParseException Rule
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
bs of
        Right Rule
r -> Rule
r
        Left ParseException
err -> [Char] -> Rule
forall a. HasCallStack => [Char] -> a
error ([Char] -> Rule) -> [Char] -> Rule
forall a b. (a -> b) -> a -> b
$ [Char]
"YAML parse error in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ParseException -> [Char]
forall a. Show a => a -> [Char]
show ParseException
err

yamlRule :: FilePath -> IO Rule
yamlRule :: [Char] -> IO Rule
yamlRule = [Char] -> IO Rule
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => [Char] -> m a
Yaml.decodeFileThrow