{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-orphans #-}

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

module Yaml where

import AST
import Control.Applicative (asum, (<|>))
import Control.Exception (throwIO)
import Data.Aeson
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Aeson.Types (formatRelativePath)
import qualified Data.ByteString as BS
import Data.FileEmbed (embedDir)
import Data.Maybe (fromMaybe)
import Data.Scientific (isInteger)
import Data.Text (Text, unpack)
import qualified Data.Text as T
import Data.Yaml (Parser)
import qualified Data.Yaml as Yaml
import Data.Yaml.Internal (Warning (DuplicateKey))
import GHC.Generics (Generic)
import Metas
import Parser
import Slots
import Text.Printf (printf)
import Text.Regex.PCRE ((=~))

shiftYamlError :: String -> String
shiftYamlError :: String -> String
shiftYamlError String
msg =
  case (String
msg String -> String -> (String, String, String, [String])
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (String
"^YAML parse exception at line ([0-9]+), column ([0-9]+)([:,])" :: String)) :: (String, String, String, [String]) of
    (String
before, String
_, String
after, [String
ln, String
col, String
sep]) ->
      String -> String -> Int -> Int -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%sYAML parse exception at line %d, column %d%s%s" String
before (String -> Int
forall a. Read a => String -> a
read String
ln Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 :: Int) (String -> Int
forall a. Read a => String -> a
read String
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 :: Int) String
sep String
after
    (String, String, String, [String])
_ -> String
msg

validateYamlObject :: (MonadFail a) => Object -> [String] -> a ()
validateYamlObject :: forall (a :: * -> *). MonadFail a => Object -> [String] -> a ()
validateYamlObject Object
v [String]
keys
  | [Key] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Key]
current Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = String -> a ()
forall a. String -> a a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Exactly one condition type is expected, when multiple condition types specified: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Key] -> String
forall a. Show a => a -> String
show [Key]
current)
  | [Key] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Key]
present = String -> a ()
forall a. String -> a a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Unknown condition type '%s', expected one of: %s" ([Key] -> String
forall a. Show a => a -> String
show [Key]
current) ([String] -> String
forall a. Show a => a -> String
show [String]
keys))
  | Bool
otherwise = () -> a ()
forall a. a -> a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    present :: [Key.Key]
    present :: [Key]
present = (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> Object -> Bool
forall a. Key -> KeyMap a -> Bool
`KeyMap.member` Object
v) ((String -> Key) -> [String] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map String -> Key
Key.fromString [String]
keys)
    current :: [Key.Key]
    current :: [Key]
current = Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
v

validateKnownYamlKeys :: (MonadFail a) => Object -> [String] -> a ()
validateKnownYamlKeys :: forall (a :: * -> *). MonadFail a => Object -> [String] -> a ()
validateKnownYamlKeys Object
v [String]
keys =
  let unknown :: [Key]
unknown = (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Key
key -> Key
key Key -> [Key] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String -> Key) -> [String] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map String -> Key
Key.fromString [String]
keys) (Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
v)
   in case [Key]
unknown of
        [] -> () -> a ()
forall a. a -> a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Key
key : [Key]
_ -> String -> a ()
forall a. String -> a a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Unknown key '%s', expected one of: %s" (Key -> String
forall a. Show a => a -> String
show Key
key) ([String] -> String
forall a. Show a => a -> String
show [String]
keys))

parseJSON' :: String -> (String -> Either String a) -> Value -> Parser a
parseJSON' :: forall a.
String -> (String -> Either String a) -> Value -> Parser a
parseJSON' String
nm String -> Either String a
func =
  String -> (Text -> Parser a) -> Value -> Parser a
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText
    String
nm
    ( \Text
txt -> case String -> Either String a
func (Text -> String
unpack Text
txt) of
        Left String
err -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
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 Attribute where
  parseJSON :: Value -> Parser Attribute
parseJSON =
    String -> (Text -> Parser Attribute) -> Value -> Parser Attribute
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText
      String
"Attribute"
      ( \Text
txt -> case Text -> String
unpack Text
txt of
          String
"λ" -> Attribute -> Parser Attribute
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
AtLambda
          String
"Δ" -> Attribute -> Parser Attribute
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
AtDelta
          String
other -> case String -> Either String Attribute
parseAttribute String
other of
            Left String
err -> String -> Parser Attribute
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
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 Alpha where
  parseJSON :: Value -> Parser Alpha
parseJSON = String -> (String -> Either String Alpha) -> Value -> Parser Alpha
forall a.
String -> (String -> Either String a) -> Value -> Parser a
parseJSON' String
"Alpha" String -> Either String Alpha
parseAlpha

instance FromJSON Bytes where
  parseJSON :: Value -> Parser Bytes
parseJSON = String -> (String -> Either String Bytes) -> Value -> Parser Bytes
forall a.
String -> (String -> Either String a) -> Value -> Parser a
parseJSON' String
"Bytes" String -> Either String Bytes
parseBytes

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

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

instance FromJSON Number where
  parseJSON :: Value -> Parser Number
parseJSON Value
v = case Value
v of
    Object Object
o -> do
      Object -> [String] -> Parser ()
forall (a :: * -> *). MonadFail a => Object -> [String] -> a ()
validateYamlObject Object
o [String
"length", String
"domain"]
      [Parser Number] -> Parser Number
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ 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"
        , Binding -> Number
Domain (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
"domain"
        ]
    Number Scientific
num
      | Integer -> Rational
forall a. Real a => a -> Rational
toRational (Scientific -> Integer
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
num :: Integer) Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= Scientific -> Rational
forall a. Real a => a -> Rational
toRational Scientific
num -> String -> Parser Number
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Expected an integer, got a fractional number %s" (Scientific -> String
forall a. Show a => a -> String
show Scientific
num))
      | (Scientific -> Integer
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
num :: Integer) 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
|| (Scientific -> Integer
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
num :: Integer) 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) -> String -> Parser Number
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The literal %s does not fit into Int" (Scientific -> String
forall a. Show a => a -> String
show Scientific
num))
      | Bool
otherwise -> Number -> Parser Number
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Number
Literal (Scientific -> Int
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
num))
    String Text
txt -> case String -> Either String (Either Slot Text)
parseIndex (Text -> String
unpack Text
txt) of
      Right (Right Text
mt) -> Number -> Parser Number
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Number
MetaIndex Text
mt)
      Right (Left Slot
slot) -> Number -> Parser Number
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Slot -> Number
AnyIndex Slot
slot)
      Left String
err -> String -> Parser Number
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Value
_ ->
      String -> Parser Number
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected a numerable expression (object, number or index meta)"

instance FromJSON Comparable where
  parseJSON :: Value -> Parser Comparable
parseJSON (Number Scientific
num)
    | Scientific -> Bool
isInteger Scientific
num Bool -> Bool -> Bool
&& ((Scientific -> Integer
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
num :: Integer) 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
|| (Scientific -> Integer
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
num :: Integer) 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)) =
        String -> Parser Comparable
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The literal %s does not fit into Int" (Scientific -> String
forall a. Show a => a -> String
show Scientific
num))
  parseJSON v :: Value
v@(Number Scientific
_) = 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
  parseJSON v :: Value
v@(Object Object
_) = 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
  parseJSON v :: Value
v@(String Text
_) =
    (Parser Comparable -> Parser Comparable -> Parser Comparable)
-> [Parser Comparable] -> Parser Comparable
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1
      Parser Comparable -> Parser Comparable -> Parser Comparable
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
      [ 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
      , Expression -> Comparable
CmpExpr (Expression -> Comparable)
-> Parser Expression -> Parser Comparable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Expression
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
      ]
  parseJSON Value
_ = String -> Parser Comparable
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"An argument of 'eq' or 'gt' is a number, an attribute, an expression, or an object of 'length' or 'domain'"

instance FromJSON Condition where
  parseJSON :: Value -> Parser Condition
parseJSON = String -> (Object -> Parser Condition) -> Value -> Parser Condition
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Condition" Object -> Parser Condition
parseCondition

parseCondition :: Object -> Parser Condition
parseCondition :: Object -> Parser Condition
parseCondition Object
v = do
  Object -> [String] -> Parser ()
forall (a :: * -> *). MonadFail a => Object -> [String] -> a ()
validateYamlObject Object
v [String
"and", String
"or", String
"not", String
"nf", String
"absolute", String
"eq", String
"gt", String
"in", String
"matches", String
"part-of", String
"disjoint", String
"formation"]
  case Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
v of
    [Key
key] -> case Key -> String
Key.toString Key
key of
      String
"and" -> do
        [Condition]
conds <- Object
v Object -> Key -> Parser [Condition]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"and"
        if [Condition] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Condition]
conds
          then String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The 'and' condition requires at least one element"
          else Condition -> Parser Condition
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Condition] -> Condition
And [Condition]
conds)
      String
"or" -> do
        [Condition]
conds <- Object
v Object -> Key -> Parser [Condition]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"or"
        if [Condition] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Condition]
conds
          then String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The 'or' condition requires at least one element"
          else Condition -> Parser Condition
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Condition] -> Condition
Or [Condition]
conds)
      String
"not" -> 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"
      String
"nf" -> 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"
      String
"absolute" -> Expression -> Condition
Absolute (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
"absolute"
      String
"formation" -> Expression -> Condition
IsFormation (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
"formation"
      String
"disjoint" -> do
        [Value]
vals <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"disjoint"
        case [Value]
vals of
          [Value
attrs_, Value
bds_] -> [Attribute] -> [Binding] -> Condition
Disjoint ([Attribute] -> [Binding] -> Condition)
-> Parser [Attribute] -> Parser ([Binding] -> Condition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser [Attribute]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
attrs_ Parser ([Binding] -> Condition)
-> Parser [Binding] -> 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 [Binding]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
bds_
          [Value]
_ -> String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'disjoint' expects exactly two arguments"
      String
"eq" -> 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]
_ -> String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'eq' expects exactly two arguments"
      String
"gt" -> do
        [Value]
vals <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"gt"
        case [Value]
vals of
          [Value
left_, Value
right_] -> Comparable -> Comparable -> Condition
Gt (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]
_ -> String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'gt' expects exactly two arguments"
      String
"in" -> do
        [Value]
vals <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"in"
        case [Value]
vals of
          [Value
attrs_, Value
bds_] -> [Attribute] -> [Binding] -> Condition
In ([Attribute] -> [Binding] -> Condition)
-> Parser [Attribute] -> Parser ([Binding] -> Condition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser [Attribute]
forall a. FromJSON a => Value -> Parser [a]
several Value
attrs_ Parser ([Binding] -> Condition)
-> Parser [Binding] -> 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 [Binding]
forall a. FromJSON a => Value -> Parser [a]
several Value
bds_
          [Value]
_ -> String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'in' expects exactly two arguments"
      String
"matches" -> do
        [Value]
vals <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"matches"
        case [Value]
vals of
          [Value
pat, Value
ex] -> String -> Expression -> Condition
Matches (String -> Expression -> Condition)
-> Parser String -> Parser (Expression -> Condition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser String
forall a. FromJSON a => Value -> Parser a
parseJSON Value
pat Parser (Expression -> Condition)
-> Parser Expression -> 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 Expression
forall a. FromJSON a => Value -> Parser a
parseJSON Value
ex
          [Value]
_ -> String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'matches' expects exactly two arguments"
      String
"part-of" -> do
        [Value]
vals <- Object
v Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"part-of"
        case [Value]
vals of
          [Value
ex, Value
bd] -> Expression -> Binding -> Condition
PartOf (Expression -> Binding -> Condition)
-> Parser Expression -> Parser (Binding -> Condition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Expression
forall a. FromJSON a => Value -> Parser a
parseJSON Value
ex Parser (Binding -> Condition) -> Parser Binding -> 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 Binding
forall a. FromJSON a => Value -> Parser a
parseJSON Value
bd
          [Value]
_ -> String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'part-of' expects exactly two arguments"
      String
_ -> String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unknown condition type"
    [Key]
_ -> String -> Parser Condition
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Exactly one condition type is expected"
  where
    several :: FromJSON a => Value -> Parser [a]
    several :: forall a. FromJSON a => Value -> Parser [a]
several Value
val = Value -> Parser [a]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val Parser [a] -> Parser [a] -> Parser [a]
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> [a]) -> Parser a -> Parser [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val)

instance FromJSON ExtraArgument where
  parseJSON :: Value -> Parser ExtraArgument
parseJSON v :: Value
v@(String Text
_) =
    (Parser ExtraArgument
 -> Parser ExtraArgument -> Parser ExtraArgument)
-> [Parser ExtraArgument] -> Parser ExtraArgument
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1
      Parser ExtraArgument
-> Parser ExtraArgument -> Parser ExtraArgument
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
      [ Attribute -> ExtraArgument
ArgAttribute (Attribute -> ExtraArgument)
-> Parser Attribute -> Parser ExtraArgument
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
      , Binding -> ExtraArgument
ArgBinding (Binding -> ExtraArgument)
-> Parser Binding -> Parser ExtraArgument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Binding
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
      , Bytes -> ExtraArgument
ArgBytes (Bytes -> ExtraArgument) -> Parser Bytes -> Parser ExtraArgument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Bytes
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
      , Expression -> ExtraArgument
ArgExpression (Expression -> ExtraArgument)
-> Parser Expression -> Parser ExtraArgument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Expression
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
      ]
  parseJSON Value
_ = String -> Parser ExtraArgument
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"An argument of a 'where' function is a string holding an attribute, a binding, bytes or an expression"

instance FromJSON Extra where
  parseJSON :: Value -> Parser Extra
parseJSON =
    String -> (Object -> Parser Extra) -> Value -> Parser Extra
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject
      String
"Extra"
      ( \Object
o -> do
          Object -> [String] -> Parser ()
forall (a :: * -> *). MonadFail a => Object -> [String] -> a ()
validateKnownYamlKeys Object
o [String
"meta", String
"function", String
"args"]
          ExtraArgument -> String -> [ExtraArgument] -> Extra
Extra
            (ExtraArgument -> String -> [ExtraArgument] -> Extra)
-> Parser ExtraArgument
-> Parser (String -> [ExtraArgument] -> Extra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser ExtraArgument
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"meta"
            Parser (String -> [ExtraArgument] -> Extra)
-> Parser String -> Parser ([ExtraArgument] -> Extra)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"function"
            Parser ([ExtraArgument] -> Extra)
-> Parser [ExtraArgument] -> Parser Extra
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [ExtraArgument])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"args" Parser (Maybe [ExtraArgument])
-> [ExtraArgument] -> Parser [ExtraArgument]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
      )

instance FromJSON Rule where
  parseJSON :: Value -> Parser Rule
parseJSON value :: Value
value@(Object Object
fields) = do
    Object -> [String] -> Parser ()
forall (a :: * -> *). MonadFail a => Object -> [String] -> a ()
validateKnownYamlKeys Object
fields [String
"name", String
"label", String
"description", String
"pattern", String
"result", String
"e-match", String
"when", String
"having", String
"where"]
    Rule
rule <-
      Options -> Value -> Parser Rule
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON
        Options
defaultOptions
          { fieldLabelModifier = \case
              String
"where_" -> String
"where"
              String
other -> String
other
          }
        Value
value
    String -> Value -> Parser ()
universeless Rule
rule.name Value
value
    String -> String -> Expression -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless Rule
rule.name String
"result" Rule
rule.result
    String -> String -> Maybe Condition -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless Rule
rule.name String
"when" Rule
rule.when
    String -> String -> Maybe [Extra] -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless Rule
rule.name String
"where" Rule
rule.where_
    String -> String -> Maybe Condition -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless Rule
rule.name String
"having" Rule
rule.having
    Rule -> [Text] -> [Extra] -> Parser ()
targets Rule
rule (Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.pattern) ([Extra] -> Maybe [Extra] -> [Extra]
forall a. a -> Maybe a -> a
fromMaybe [] Rule
rule.where_)
    Rule -> [Text] -> String -> [Text] -> Parser ()
unread Rule
rule ([Text] -> [Text]
named (Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.pattern)) String
"when" (Maybe Condition -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.when)
    Rule -> [Text] -> [Extra] -> Parser ()
steps Rule
rule ([Text] -> [Text]
named (Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.pattern)) ([Extra] -> Maybe [Extra] -> [Extra]
forall a. a -> Maybe a -> a
fromMaybe [] Rule
rule.where_)
    Rule -> Parser Rule
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule
rule
    where
      targets :: Rule -> [Text] -> [Extra] -> Parser ()
      targets :: Rule -> [Text] -> [Extra] -> Parser ()
targets Rule
_ [Text]
_ [] = () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      targets Rule
rule [Text]
known (Extra
extra : [Extra]
rest) = case Extra
extra.meta of
        ArgExpression (ExMeta Text
bound) -> Rule -> [Text] -> Text -> Parser ()
fresh Rule
rule [Text]
known Text
bound Parser () -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rule -> [Text] -> [Extra] -> Parser ()
targets Rule
rule (Text
bound Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
known) [Extra]
rest
        ArgAttribute (AtMeta Text
bound) -> Rule -> [Text] -> Text -> Parser ()
fresh Rule
rule [Text]
known Text
bound Parser () -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rule -> [Text] -> [Extra] -> Parser ()
targets Rule
rule (Text
bound Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
known) [Extra]
rest
        ArgBinding (BiMeta Text
bound) -> Rule -> [Text] -> Text -> Parser ()
fresh Rule
rule [Text]
known Text
bound Parser () -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rule -> [Text] -> [Extra] -> Parser ()
targets Rule
rule (Text
bound Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
known) [Extra]
rest
        ArgBytes (BtMeta Text
bound) -> Rule -> [Text] -> Text -> Parser ()
fresh Rule
rule [Text]
known Text
bound Parser () -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rule -> [Text] -> [Extra] -> Parser ()
targets Rule
rule (Text
bound Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
known) [Extra]
rest
        ExtraArgument
_ -> String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The rule '%s' has a 'where' step whose 'meta' is not a meta, while only a meta can take its result" Rule
rule.name)
      fresh :: Rule -> [Text] -> Text -> Parser ()
      fresh :: Rule -> [Text] -> Text -> Parser ()
fresh Rule
rule [Text]
known Text
bound
        | Text
bound Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
known = String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The rule '%s' has a 'where' step that binds the meta '%s' again, while it is already bound" Rule
rule.name (Text -> String
unpack Text
bound))
        | Bool
otherwise = () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      named :: [Text] -> [Text]
      named :: [Text] -> [Text]
named = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> (Text -> Int) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length)
      steps :: Rule -> [Text] -> [Extra] -> Parser ()
      steps :: Rule -> [Text] -> [Extra] -> Parser ()
steps Rule
rule [Text]
known [] = do
        Rule -> [Text] -> String -> [Text] -> Parser ()
unread Rule
rule [Text]
known String
"result" (Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.result)
        Rule -> [Text] -> String -> [Text] -> Parser ()
unread Rule
rule [Text]
known String
"having" (Maybe Condition -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.having)
      steps Rule
rule [Text]
known (Extra
extra : [Extra]
rest) = do
        Rule -> [Text] -> String -> [Text] -> Parser ()
unread Rule
rule [Text]
known String
"where" ([ExtraArgument] -> [Text]
forall a. Metas a => a -> [Text]
metas Extra
extra.args)
        Rule -> [Text] -> [Extra] -> Parser ()
steps Rule
rule ([Text]
known [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text] -> [Text]
named (ExtraArgument -> [Text]
forall a. Metas a => a -> [Text]
metas Extra
extra.meta)) [Extra]
rest
      unread :: Rule -> [Text] -> String -> [Text] -> Parser ()
      unread :: Rule -> [Text] -> String -> [Text] -> Parser ()
unread Rule
rule [Text]
known String
field [Text]
used = case (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
known) ([Text] -> [Text]
named [Text]
used) of
        [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Text
missing : [Text]
_ ->
          String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
            ( String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
                String
"The rule '%s' reads the meta '%s' it never binds, in '%s', since neither its pattern nor an earlier 'where' step binds it"
                Rule
rule.name
                (Text -> String
unpack Text
missing)
                String
field
            )
  parseJSON Value
value = Options -> Value -> Parser Rule
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions Value
value

data Number
  = MetaIndex Text
  | AnyIndex Slot
  | Length Binding
  | Domain Binding
  | Literal Int
  deriving (Number -> Number -> Bool
(Number -> Number -> Bool)
-> (Number -> Number -> Bool) -> Eq Number
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Number -> Number -> Bool
== :: Number -> Number -> Bool
$c/= :: Number -> Number -> Bool
/= :: Number -> Number -> Bool
Eq, (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 -> String -> String
[Number] -> String -> String
Number -> String
(Int -> Number -> String -> String)
-> (Number -> String)
-> ([Number] -> String -> String)
-> Show Number
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Number -> String -> String
showsPrec :: Int -> Number -> String -> String
$cshow :: Number -> String
show :: Number -> String
$cshowList :: [Number] -> String -> String
showList :: [Number] -> String -> String
Show)

data Comparable
  = CmpAttr Attribute
  | CmpNum Number
  | CmpExpr Expression
  deriving (Comparable -> Comparable -> Bool
(Comparable -> Comparable -> Bool)
-> (Comparable -> Comparable -> Bool) -> Eq Comparable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Comparable -> Comparable -> Bool
== :: Comparable -> Comparable -> Bool
$c/= :: Comparable -> Comparable -> Bool
/= :: Comparable -> Comparable -> Bool
Eq, (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 -> String -> String
[Comparable] -> String -> String
Comparable -> String
(Int -> Comparable -> String -> String)
-> (Comparable -> String)
-> ([Comparable] -> String -> String)
-> Show Comparable
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Comparable -> String -> String
showsPrec :: Int -> Comparable -> String -> String
$cshow :: Comparable -> String
show :: Comparable -> String
$cshowList :: [Comparable] -> String -> String
showList :: [Comparable] -> String -> String
Show)

data Condition
  = And [Condition]
  | Or [Condition]
  | In [Attribute] [Binding]
  | Not Condition
  | Eq Comparable Comparable
  | Gt Comparable Comparable
  | NF Expression
  | Absolute Expression
  | Matches String Expression
  | PartOf Expression Binding
  | Disjoint [Attribute] [Binding]
  | IsFormation Expression
  deriving (Condition -> Condition -> Bool
(Condition -> Condition -> Bool)
-> (Condition -> Condition -> Bool) -> Eq Condition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Condition -> Condition -> Bool
== :: Condition -> Condition -> Bool
$c/= :: Condition -> Condition -> Bool
/= :: Condition -> Condition -> Bool
Eq, (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 -> String -> String
[Condition] -> String -> String
Condition -> String
(Int -> Condition -> String -> String)
-> (Condition -> String)
-> ([Condition] -> String -> String)
-> Show Condition
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Condition -> String -> String
showsPrec :: Int -> Condition -> String -> String
$cshow :: Condition -> String
show :: Condition -> String
$cshowList :: [Condition] -> String -> String
showList :: [Condition] -> String -> String
Show)

data ExtraArgument
  = ArgAttribute Attribute
  | ArgExpression Expression
  | ArgBinding Binding
  | ArgBytes Bytes
  deriving ((forall x. ExtraArgument -> Rep ExtraArgument x)
-> (forall x. Rep ExtraArgument x -> ExtraArgument)
-> Generic ExtraArgument
forall x. Rep ExtraArgument x -> ExtraArgument
forall x. ExtraArgument -> Rep ExtraArgument x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ExtraArgument -> Rep ExtraArgument x
from :: forall x. ExtraArgument -> Rep ExtraArgument x
$cto :: forall x. Rep ExtraArgument x -> ExtraArgument
to :: forall x. Rep ExtraArgument x -> ExtraArgument
Generic, Int -> ExtraArgument -> String -> String
[ExtraArgument] -> String -> String
ExtraArgument -> String
(Int -> ExtraArgument -> String -> String)
-> (ExtraArgument -> String)
-> ([ExtraArgument] -> String -> String)
-> Show ExtraArgument
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ExtraArgument -> String -> String
showsPrec :: Int -> ExtraArgument -> String -> String
$cshow :: ExtraArgument -> String
show :: ExtraArgument -> String
$cshowList :: [ExtraArgument] -> String -> String
showList :: [ExtraArgument] -> String -> String
Show)

data Extra = Extra
  { Extra -> ExtraArgument
meta :: ExtraArgument
  , Extra -> String
function :: String
  , Extra -> [ExtraArgument]
args :: [ExtraArgument]
  }
  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 -> String -> String
[Extra] -> String -> String
Extra -> String
(Int -> Extra -> String -> String)
-> (Extra -> String) -> ([Extra] -> String -> String) -> Show Extra
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Extra -> String -> String
showsPrec :: Int -> Extra -> String -> String
$cshow :: Extra -> String
show :: Extra -> String
$cshowList :: [Extra] -> String -> String
showList :: [Extra] -> String -> String
Show)

data Rule = Rule
  { Rule -> String
name :: String
  , Rule -> Maybe String
label :: Maybe String
  , Rule -> Maybe String
description :: Maybe String
  , Rule -> Expression
pattern :: Expression
  , Rule -> Expression
result :: Expression
  , Rule -> Maybe Condition
when :: Maybe Condition
  , Rule -> Maybe [Extra]
where_ :: Maybe [Extra]
  , Rule -> Maybe Condition
having :: Maybe Condition
  }
  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 -> String -> String
[Rule] -> String -> String
Rule -> String
(Int -> Rule -> String -> String)
-> (Rule -> String) -> ([Rule] -> String -> String) -> Show Rule
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Rule -> String -> String
showsPrec :: Int -> Rule -> String -> String
$cshow :: Rule -> String
show :: Rule -> String
$cshowList :: [Rule] -> String -> String
showList :: [Rule] -> String -> String
Show)

instance Slots Condition where
  slots :: Condition -> [Slot]
slots (And [Condition]
conds) = [Condition] -> [Slot]
forall a. Slots a => a -> [Slot]
slots [Condition]
conds
  slots (Or [Condition]
conds) = [Condition] -> [Slot]
forall a. Slots a => a -> [Slot]
slots [Condition]
conds
  slots (Not Condition
cond) = Condition -> [Slot]
forall a. Slots a => a -> [Slot]
slots Condition
cond
  slots (In [Attribute]
attrs [Binding]
bds) = [Attribute] -> [Slot]
forall a. Slots a => a -> [Slot]
slots [Attribute]
attrs [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ [Binding] -> [Slot]
forall a. Slots a => a -> [Slot]
slots [Binding]
bds
  slots (Eq Comparable
left Comparable
right) = Comparable -> [Slot]
forall a. Slots a => a -> [Slot]
slots Comparable
left [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ Comparable -> [Slot]
forall a. Slots a => a -> [Slot]
slots Comparable
right
  slots (Gt Comparable
left Comparable
right) = Comparable -> [Slot]
forall a. Slots a => a -> [Slot]
slots Comparable
left [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ Comparable -> [Slot]
forall a. Slots a => a -> [Slot]
slots Comparable
right
  slots (NF Expression
expr) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr
  slots (Absolute Expression
expr) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr
  slots (Matches String
_ Expression
expr) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr
  slots (PartOf Expression
expr Binding
bd) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ Binding -> [Slot]
forall a. Slots a => a -> [Slot]
slots Binding
bd
  slots (Disjoint [Attribute]
attrs [Binding]
bds) = [Attribute] -> [Slot]
forall a. Slots a => a -> [Slot]
slots [Attribute]
attrs [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ [Binding] -> [Slot]
forall a. Slots a => a -> [Slot]
slots [Binding]
bds
  slots (IsFormation Expression
expr) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr

instance Slots Comparable where
  slots :: Comparable -> [Slot]
slots (CmpAttr Attribute
attr) = Attribute -> [Slot]
forall a. Slots a => a -> [Slot]
slots Attribute
attr
  slots (CmpNum Number
num) = Number -> [Slot]
forall a. Slots a => a -> [Slot]
slots Number
num
  slots (CmpExpr Expression
expr) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr

instance Slots Number where
  slots :: Number -> [Slot]
slots (AnyIndex Slot
slot) = [Slot
slot]
  slots (Length Binding
bd) = Binding -> [Slot]
forall a. Slots a => a -> [Slot]
slots Binding
bd
  slots (Domain Binding
bd) = Binding -> [Slot]
forall a. Slots a => a -> [Slot]
slots Binding
bd
  slots (MetaIndex Text
_) = []
  slots (Literal Int
_) = []

instance Slots ExtraArgument where
  slots :: ExtraArgument -> [Slot]
slots (ArgAttribute Attribute
attr) = Attribute -> [Slot]
forall a. Slots a => a -> [Slot]
slots Attribute
attr
  slots (ArgExpression Expression
expr) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr
  slots (ArgBinding Binding
bd) = Binding -> [Slot]
forall a. Slots a => a -> [Slot]
slots Binding
bd
  slots (ArgBytes Bytes
bts) = Bytes -> [Slot]
forall a. Slots a => a -> [Slot]
slots Bytes
bts

instance Slots Extra where
  slots :: Extra -> [Slot]
slots Extra
extra = ExtraArgument -> [Slot]
forall a. Slots a => a -> [Slot]
slots Extra
extra.meta [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ [ExtraArgument] -> [Slot]
forall a. Slots a => a -> [Slot]
slots Extra
extra.args

instance Slots Premise where
  slots :: Premise -> [Slot]
slots Premise
premise = Operation -> [Slot]
forall a. Slots a => a -> [Slot]
slots Premise
premise.operation

instance Slots Operation where
  slots :: Operation -> [Slot]
slots (OpMorph Expression
expr Expression
universe) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
universe
  slots (OpNormalize Expression
expr) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr
  slots (OpEvaluate Expression
expr Expression
universe) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
universe
  slots (OpContextualize Expression
expr Expression
context) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
context
  slots (OpDataize Expression
expr Expression
universe) = Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
expr [Slot] -> [Slot] -> [Slot]
forall a. [a] -> [a] -> [a]
++ Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
universe

instance Metas Condition where
  metas :: Condition -> [Text]
metas (And [Condition]
conds) = [Condition] -> [Text]
forall a. Metas a => a -> [Text]
metas [Condition]
conds
  metas (Or [Condition]
conds) = [Condition] -> [Text]
forall a. Metas a => a -> [Text]
metas [Condition]
conds
  metas (Not Condition
cond) = Condition -> [Text]
forall a. Metas a => a -> [Text]
metas Condition
cond
  metas (In [Attribute]
attrs [Binding]
bds) = [Attribute] -> [Text]
forall a. Metas a => a -> [Text]
metas [Attribute]
attrs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Binding] -> [Text]
forall a. Metas a => a -> [Text]
metas [Binding]
bds
  metas (Eq Comparable
left Comparable
right) = Comparable -> [Text]
forall a. Metas a => a -> [Text]
metas Comparable
left [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Comparable -> [Text]
forall a. Metas a => a -> [Text]
metas Comparable
right
  metas (Gt Comparable
left Comparable
right) = Comparable -> [Text]
forall a. Metas a => a -> [Text]
metas Comparable
left [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Comparable -> [Text]
forall a. Metas a => a -> [Text]
metas Comparable
right
  metas (NF Expression
expr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  metas (Absolute Expression
expr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  metas (Matches String
_ Expression
expr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  metas (PartOf Expression
expr Binding
bd) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Binding -> [Text]
forall a. Metas a => a -> [Text]
metas Binding
bd
  metas (Disjoint [Attribute]
attrs [Binding]
bds) = [Attribute] -> [Text]
forall a. Metas a => a -> [Text]
metas [Attribute]
attrs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Binding] -> [Text]
forall a. Metas a => a -> [Text]
metas [Binding]
bds
  metas (IsFormation Expression
expr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  bare :: [Text] -> Condition -> Condition
bare [Text]
names (And [Condition]
conds) = [Condition] -> Condition
And ([Text] -> [Condition] -> [Condition]
forall a. Metas a => [Text] -> a -> a
bare [Text]
names [Condition]
conds)
  bare [Text]
names (Or [Condition]
conds) = [Condition] -> Condition
Or ([Text] -> [Condition] -> [Condition]
forall a. Metas a => [Text] -> a -> a
bare [Text]
names [Condition]
conds)
  bare [Text]
names (Not Condition
cond) = Condition -> Condition
Not ([Text] -> Condition -> Condition
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Condition
cond)
  bare [Text]
names (In [Attribute]
attrs [Binding]
bds) = [Attribute] -> [Binding] -> Condition
In ([Text] -> [Attribute] -> [Attribute]
forall a. Metas a => [Text] -> a -> a
bare [Text]
names [Attribute]
attrs) ([Text] -> [Binding] -> [Binding]
forall a. Metas a => [Text] -> a -> a
bare [Text]
names [Binding]
bds)
  bare [Text]
names (Eq Comparable
left Comparable
right) = Comparable -> Comparable -> Condition
Eq ([Text] -> Comparable -> Comparable
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Comparable
left) ([Text] -> Comparable -> Comparable
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Comparable
right)
  bare [Text]
names (Gt Comparable
left Comparable
right) = Comparable -> Comparable -> Condition
Gt ([Text] -> Comparable -> Comparable
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Comparable
left) ([Text] -> Comparable -> Comparable
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Comparable
right)
  bare [Text]
names (NF Expression
expr) = Expression -> Condition
NF ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)
  bare [Text]
names (Absolute Expression
expr) = Expression -> Condition
Absolute ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)
  bare [Text]
names (Matches String
regex Expression
expr) = String -> Expression -> Condition
Matches String
regex ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)
  bare [Text]
names (PartOf Expression
expr Binding
bd) = Expression -> Binding -> Condition
PartOf ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr) ([Text] -> Binding -> Binding
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Binding
bd)
  bare [Text]
names (Disjoint [Attribute]
attrs [Binding]
bds) = [Attribute] -> [Binding] -> Condition
Disjoint ([Text] -> [Attribute] -> [Attribute]
forall a. Metas a => [Text] -> a -> a
bare [Text]
names [Attribute]
attrs) ([Text] -> [Binding] -> [Binding]
forall a. Metas a => [Text] -> a -> a
bare [Text]
names [Binding]
bds)
  bare [Text]
names (IsFormation Expression
expr) = Expression -> Condition
IsFormation ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)

instance Metas Comparable where
  metas :: Comparable -> [Text]
metas (CmpAttr Attribute
attr) = Attribute -> [Text]
forall a. Metas a => a -> [Text]
metas Attribute
attr
  metas (CmpNum Number
num) = Number -> [Text]
forall a. Metas a => a -> [Text]
metas Number
num
  metas (CmpExpr Expression
expr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  bare :: [Text] -> Comparable -> Comparable
bare [Text]
names (CmpAttr Attribute
attr) = Attribute -> Comparable
CmpAttr ([Text] -> Attribute -> Attribute
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Attribute
attr)
  bare [Text]
names (CmpNum Number
num) = Number -> Comparable
CmpNum ([Text] -> Number -> Number
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Number
num)
  bare [Text]
names (CmpExpr Expression
expr) = Expression -> Comparable
CmpExpr ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)

instance Metas Number where
  metas :: Number -> [Text]
metas (MetaIndex Text
named) = Text -> [Text]
forall a. Metas a => a -> [Text]
metas Text
named
  metas (AnyIndex Slot
slot) = Slot -> [Text]
forall a. Metas a => a -> [Text]
metas Slot
slot
  metas (Length Binding
bd) = Binding -> [Text]
forall a. Metas a => a -> [Text]
metas Binding
bd
  metas (Domain Binding
bd) = Binding -> [Text]
forall a. Metas a => a -> [Text]
metas Binding
bd
  metas (Literal Int
_) = []
  bare :: [Text] -> Number -> Number
bare [Text]
names (MetaIndex Text
named) = Text -> Number
MetaIndex ([Text] -> Text -> Text
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Text
named)
  bare [Text]
names (Length Binding
bd) = Binding -> Number
Length ([Text] -> Binding -> Binding
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Binding
bd)
  bare [Text]
names (Domain Binding
bd) = Binding -> Number
Domain ([Text] -> Binding -> Binding
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Binding
bd)
  bare [Text]
_ Number
num = Number
num

instance Metas ExtraArgument where
  metas :: ExtraArgument -> [Text]
metas (ArgAttribute Attribute
attr) = Attribute -> [Text]
forall a. Metas a => a -> [Text]
metas Attribute
attr
  metas (ArgExpression Expression
expr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  metas (ArgBinding Binding
bd) = Binding -> [Text]
forall a. Metas a => a -> [Text]
metas Binding
bd
  metas (ArgBytes Bytes
bts) = Bytes -> [Text]
forall a. Metas a => a -> [Text]
metas Bytes
bts
  bare :: [Text] -> ExtraArgument -> ExtraArgument
bare [Text]
names (ArgAttribute Attribute
attr) = Attribute -> ExtraArgument
ArgAttribute ([Text] -> Attribute -> Attribute
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Attribute
attr)
  bare [Text]
names (ArgExpression Expression
expr) = Expression -> ExtraArgument
ArgExpression ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)
  bare [Text]
names (ArgBinding Binding
bd) = Binding -> ExtraArgument
ArgBinding ([Text] -> Binding -> Binding
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Binding
bd)
  bare [Text]
names (ArgBytes Bytes
bts) = Bytes -> ExtraArgument
ArgBytes ([Text] -> Bytes -> Bytes
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Bytes
bts)

instance Metas Extra where
  metas :: Extra -> [Text]
metas Extra
extra = ExtraArgument -> [Text]
forall a. Metas a => a -> [Text]
metas Extra
extra.meta [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [ExtraArgument] -> [Text]
forall a. Metas a => a -> [Text]
metas Extra
extra.args
  bare :: [Text] -> Extra -> Extra
bare [Text]
names Extra
extra = Extra
extra{meta = bare names extra.meta, args = bare names extra.args}

instance Metas Premise where
  metas :: Premise -> [Text]
metas Premise
premise = Text -> [Text]
forall a. Metas a => a -> [Text]
metas Premise
premise.result [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Operation -> [Text]
forall a. Metas a => a -> [Text]
metas Premise
premise.operation
  bare :: [Text] -> Premise -> Premise
bare [Text]
names Premise
premise = Premise
premise{result = bare names premise.result, operation = bare names premise.operation}

instance Metas Operation where
  metas :: Operation -> [Text]
metas (OpMorph Expression
expr Expression
universe) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
universe
  metas (OpNormalize Expression
expr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  metas (OpEvaluate Expression
expr Expression
universe) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
universe
  metas (OpContextualize Expression
expr Expression
context) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
context
  metas (OpDataize Expression
expr Expression
universe) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
universe
  bare :: [Text] -> Operation -> Operation
bare [Text]
names (OpMorph Expression
expr Expression
universe) = Expression -> Expression -> Operation
OpMorph ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr) ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
universe)
  bare [Text]
names (OpNormalize Expression
expr) = Expression -> Operation
OpNormalize ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)
  bare [Text]
names (OpEvaluate Expression
expr Expression
universe) = Expression -> Expression -> Operation
OpEvaluate ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr) ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
universe)
  bare [Text]
names (OpContextualize Expression
expr Expression
context) = Expression -> Expression -> Operation
OpContextualize ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr) ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
context)
  bare [Text]
names (OpDataize Expression
expr Expression
universe) = Expression -> Expression -> Operation
OpDataize ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr) ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
universe)

instance Metas Rule where
  metas :: Rule -> [Text]
metas Rule
rule = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.pattern [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.result [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Condition -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.when [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Condition -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.having [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe [Extra] -> [Text]
forall a. Metas a => a -> [Text]
metas Rule
rule.where_
  bare :: [Text] -> Rule -> Rule
bare [Text]
names Rule
rule =
    Rule
rule
      { pattern = bare names rule.pattern
      , result = bare names rule.result
      , when = bare names rule.when
      , having = bare names rule.having
      , where_ = bare names rule.where_
      }

instance Metas MorphRule where
  metas :: MorphRule -> [Text]
metas MorphRule
rule = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas MorphRule
rule.match [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas MorphRule
rule.ematch [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas MorphRule
rule.nresult [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Condition -> [Text]
forall a. Metas a => a -> [Text]
metas MorphRule
rule.when [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Premise] -> [Text]
forall a. Metas a => a -> [Text]
metas MorphRule
rule.premises
  bare :: [Text] -> MorphRule -> MorphRule
bare [Text]
names MorphRule
rule =
    MorphRule
rule
      { match = bare names rule.match
      , ematch = bare names rule.ematch
      , nresult = bare names rule.nresult
      , when = bare names rule.when
      , premises = bare names rule.premises
      }

instance Metas DataizeRule where
  metas :: DataizeRule -> [Text]
metas DataizeRule
rule = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas DataizeRule
rule.match [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas DataizeRule
rule.ematch [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Bytes -> [Text]
forall a. Metas a => a -> [Text]
metas DataizeRule
rule.dresult [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Maybe Condition -> [Text]
forall a. Metas a => a -> [Text]
metas DataizeRule
rule.when [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Premise] -> [Text]
forall a. Metas a => a -> [Text]
metas DataizeRule
rule.premises
  bare :: [Text] -> DataizeRule -> DataizeRule
bare [Text]
names DataizeRule
rule =
    DataizeRule
rule
      { match = bare names rule.match
      , ematch = bare names rule.ematch
      , dresult = bare names rule.dresult
      , when = bare names rule.when
      , premises = bare names rule.premises
      }

instance Metas ContextualizeRule where
  metas :: ContextualizeRule -> [Text]
metas ContextualizeRule
rule = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas ContextualizeRule
rule.match [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas ContextualizeRule
rule.cmatch [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas ContextualizeRule
rule.cresult [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Premise] -> [Text]
forall a. Metas a => a -> [Text]
metas ContextualizeRule
rule.premises
  bare :: [Text] -> ContextualizeRule -> ContextualizeRule
bare [Text]
names ContextualizeRule
rule =
    ContextualizeRule
rule
      { match = bare names rule.match
      , cmatch = bare names rule.cmatch
      , cresult = bare names rule.cresult
      , premises = bare names rule.premises
      }

universeless :: String -> Value -> Parser ()
universeless :: String -> Value -> Parser ()
universeless String
rule (Object Object
fields)
  | Key -> Object -> Bool
forall a. Key -> KeyMap a -> Bool
KeyMap.member Key
"e-match" Object
fields = String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The rule '%s' carries an 'e-match', which only a morphing or a dataization rule may" String
rule)
universeless String
_ Value
_ = () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

referenceless :: (MonadFail m, Slots a) => String -> String -> a -> m ()
referenceless :: forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless String
rule String
field a
term = case a -> Maybe Text
forall a. Slots a => a -> Maybe Text
anonymous a
term of
  Maybe Text
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Just Text
kind ->
    String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
      ( String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
          String
"anonymous meta '!%s' cannot be referenced in '%s' of rule '%s'"
          (Text -> String
unpack Text
kind)
          String
field
          String
rule
      )

decodeRule :: (FromJSON a) => (FilePath, BS.ByteString) -> a
decodeRule :: forall a. FromJSON a => (String, ByteString) -> a
decodeRule (String
path, ByteString
bs) = case ByteString -> Either ParseException a
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
bs of
  Right a
rule -> a
rule
  Left ParseException
err -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"YAML parse error in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseException -> String
forall a. Show a => a -> String
show ParseException
err

normalizationRules :: [Rule]
{-# NOINLINE normalizationRules #-}
normalizationRules :: [Rule]
normalizationRules = ((String, ByteString) -> Rule) -> [(String, ByteString)] -> [Rule]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> Rule
forall a. FromJSON a => (String, ByteString) -> a
decodeRule $(embedDir "resources/normalize")

yamlRule :: FilePath -> IO Rule
yamlRule :: String -> IO Rule
yamlRule String
path = do
  Either ParseException ([Warning], Rule)
decoded <- String -> IO (Either ParseException ([Warning], Rule))
forall a.
FromJSON a =>
String -> IO (Either ParseException ([Warning], a))
Yaml.decodeFileWithWarnings String
path
  case Either ParseException ([Warning], Rule)
decoded of
    Left ParseException
err -> ParseException -> IO Rule
forall e a. Exception e => e -> IO a
throwIO ParseException
err
    Right ([Warning]
warnings, Rule
rule) -> Rule
rule Rule -> IO () -> IO Rule
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Warning -> IO ()) -> [Warning] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Warning -> IO ()
reportDuplicateKey [Warning]
warnings
  where
    reportDuplicateKey :: Warning -> IO ()
    reportDuplicateKey :: Warning -> IO ()
reportDuplicateKey (DuplicateKey JSONPath
jsonPath) =
      String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The key '%s' is repeated in the rule file '%s', only the last value is kept" (JSONPath -> String
formatRelativePath JSONPath
jsonPath) String
path)

data Premise = Premise
  { Premise -> Text
result :: Text
  , Premise -> Operation
operation :: Operation
  }
  deriving (Premise -> Premise -> Bool
(Premise -> Premise -> Bool)
-> (Premise -> Premise -> Bool) -> Eq Premise
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Premise -> Premise -> Bool
== :: Premise -> Premise -> Bool
$c/= :: Premise -> Premise -> Bool
/= :: Premise -> Premise -> Bool
Eq, (forall x. Premise -> Rep Premise x)
-> (forall x. Rep Premise x -> Premise) -> Generic Premise
forall x. Rep Premise x -> Premise
forall x. Premise -> Rep Premise x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Premise -> Rep Premise x
from :: forall x. Premise -> Rep Premise x
$cto :: forall x. Rep Premise x -> Premise
to :: forall x. Rep Premise x -> Premise
Generic, Int -> Premise -> String -> String
[Premise] -> String -> String
Premise -> String
(Int -> Premise -> String -> String)
-> (Premise -> String)
-> ([Premise] -> String -> String)
-> Show Premise
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Premise -> String -> String
showsPrec :: Int -> Premise -> String -> String
$cshow :: Premise -> String
show :: Premise -> String
$cshowList :: [Premise] -> String -> String
showList :: [Premise] -> String -> String
Show)

data Operation
  = OpMorph Expression Expression
  | OpNormalize Expression
  | OpEvaluate Expression Expression
  | OpContextualize Expression Expression
  | OpDataize Expression Expression
  deriving (Operation -> Operation -> Bool
(Operation -> Operation -> Bool)
-> (Operation -> Operation -> Bool) -> Eq Operation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Operation -> Operation -> Bool
== :: Operation -> Operation -> Bool
$c/= :: Operation -> Operation -> Bool
/= :: Operation -> Operation -> Bool
Eq, (forall x. Operation -> Rep Operation x)
-> (forall x. Rep Operation x -> Operation) -> Generic Operation
forall x. Rep Operation x -> Operation
forall x. Operation -> Rep Operation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Operation -> Rep Operation x
from :: forall x. Operation -> Rep Operation x
$cto :: forall x. Rep Operation x -> Operation
to :: forall x. Rep Operation x -> Operation
Generic, Int -> Operation -> String -> String
[Operation] -> String -> String
Operation -> String
(Int -> Operation -> String -> String)
-> (Operation -> String)
-> ([Operation] -> String -> String)
-> Show Operation
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Operation -> String -> String
showsPrec :: Int -> Operation -> String -> String
$cshow :: Operation -> String
show :: Operation -> String
$cshowList :: [Operation] -> String -> String
showList :: [Operation] -> String -> String
Show)

data MorphRule = MorphRule
  { MorphRule -> String
name :: String
  , MorphRule -> Maybe String
label :: Maybe String
  , MorphRule -> Expression
match :: Expression
  , MorphRule -> Expression
ematch :: Expression
  , MorphRule -> Expression
nresult :: Expression
  , MorphRule -> Maybe Condition
when :: Maybe Condition
  , MorphRule -> [Premise]
premises :: [Premise]
  }
  deriving ((forall x. MorphRule -> Rep MorphRule x)
-> (forall x. Rep MorphRule x -> MorphRule) -> Generic MorphRule
forall x. Rep MorphRule x -> MorphRule
forall x. MorphRule -> Rep MorphRule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MorphRule -> Rep MorphRule x
from :: forall x. MorphRule -> Rep MorphRule x
$cto :: forall x. Rep MorphRule x -> MorphRule
to :: forall x. Rep MorphRule x -> MorphRule
Generic, Int -> MorphRule -> String -> String
[MorphRule] -> String -> String
MorphRule -> String
(Int -> MorphRule -> String -> String)
-> (MorphRule -> String)
-> ([MorphRule] -> String -> String)
-> Show MorphRule
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MorphRule -> String -> String
showsPrec :: Int -> MorphRule -> String -> String
$cshow :: MorphRule -> String
show :: MorphRule -> String
$cshowList :: [MorphRule] -> String -> String
showList :: [MorphRule] -> String -> String
Show)

data DataizeRule = DataizeRule
  { DataizeRule -> String
name :: String
  , DataizeRule -> Maybe String
label :: Maybe String
  , DataizeRule -> Expression
match :: Expression
  , DataizeRule -> Expression
ematch :: Expression
  , DataizeRule -> Bytes
dresult :: Bytes
  , DataizeRule -> Maybe Condition
when :: Maybe Condition
  , DataizeRule -> [Premise]
premises :: [Premise]
  }
  deriving ((forall x. DataizeRule -> Rep DataizeRule x)
-> (forall x. Rep DataizeRule x -> DataizeRule)
-> Generic DataizeRule
forall x. Rep DataizeRule x -> DataizeRule
forall x. DataizeRule -> Rep DataizeRule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DataizeRule -> Rep DataizeRule x
from :: forall x. DataizeRule -> Rep DataizeRule x
$cto :: forall x. Rep DataizeRule x -> DataizeRule
to :: forall x. Rep DataizeRule x -> DataizeRule
Generic, Int -> DataizeRule -> String -> String
[DataizeRule] -> String -> String
DataizeRule -> String
(Int -> DataizeRule -> String -> String)
-> (DataizeRule -> String)
-> ([DataizeRule] -> String -> String)
-> Show DataizeRule
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DataizeRule -> String -> String
showsPrec :: Int -> DataizeRule -> String -> String
$cshow :: DataizeRule -> String
show :: DataizeRule -> String
$cshowList :: [DataizeRule] -> String -> String
showList :: [DataizeRule] -> String -> String
Show)

data ContextualizeRule = ContextualizeRule
  { ContextualizeRule -> String
name :: String
  , ContextualizeRule -> Maybe String
label :: Maybe String
  , ContextualizeRule -> Expression
match :: Expression
  , ContextualizeRule -> Expression
cmatch :: Expression
  , ContextualizeRule -> Expression
cresult :: Expression
  , ContextualizeRule -> [Premise]
premises :: [Premise]
  }
  deriving ((forall x. ContextualizeRule -> Rep ContextualizeRule x)
-> (forall x. Rep ContextualizeRule x -> ContextualizeRule)
-> Generic ContextualizeRule
forall x. Rep ContextualizeRule x -> ContextualizeRule
forall x. ContextualizeRule -> Rep ContextualizeRule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ContextualizeRule -> Rep ContextualizeRule x
from :: forall x. ContextualizeRule -> Rep ContextualizeRule x
$cto :: forall x. Rep ContextualizeRule x -> ContextualizeRule
to :: forall x. Rep ContextualizeRule x -> ContextualizeRule
Generic, Int -> ContextualizeRule -> String -> String
[ContextualizeRule] -> String -> String
ContextualizeRule -> String
(Int -> ContextualizeRule -> String -> String)
-> (ContextualizeRule -> String)
-> ([ContextualizeRule] -> String -> String)
-> Show ContextualizeRule
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ContextualizeRule -> String -> String
showsPrec :: Int -> ContextualizeRule -> String -> String
$cshow :: ContextualizeRule -> String
show :: ContextualizeRule -> String
$cshowList :: [ContextualizeRule] -> String -> String
showList :: [ContextualizeRule] -> String -> String
Show)

instance FromJSON Premise where
  parseJSON :: Value -> Parser Premise
parseJSON =
    String -> (Object -> Parser Premise) -> Value -> Parser Premise
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject
      String
"Premise"
      (\Object
o -> Text -> Operation -> Premise
Premise (Text -> Operation -> Premise)
-> Parser Text -> Parser (Operation -> Premise)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser Text
premiseResult Object
o Parser (Operation -> Premise) -> Parser Operation -> Parser Premise
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser Operation
premiseOperation Object
o)

premiseResult :: Object -> Parser Text
premiseResult :: Object -> Parser Text
premiseResult Object
o = do
  Maybe Expression
expr <- Object
o Object -> Key -> Parser (Maybe Expression)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"n-result"
  case Maybe Expression
expr of
    Just (ExMeta Text
metaName) -> Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
metaName
    Just (ExAny Slot
_) -> String -> Parser Text
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"an anonymous 'n-result' meta cannot be referenced"
    Just Expression
_ -> String -> Parser Text
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'n-result' must be an expression meta"
    Maybe Expression
Nothing -> do
      Maybe Bytes
bytes <- Object
o Object -> Key -> Parser (Maybe Bytes)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"d-result"
      case Maybe Bytes
bytes of
        Just (BtMeta Text
metaName) -> Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
metaName
        Just (BtAny Slot
_) -> String -> Parser Text
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"an anonymous 'd-result' meta cannot be referenced"
        Just Bytes
_ -> String -> Parser Text
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'d-result' must be a bytes meta"
        Maybe Bytes
Nothing -> String -> Parser Text
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"a premise needs an 'n-result' or 'd-result' meta"

premiseOperation :: Object -> Parser Operation
premiseOperation :: Object -> Parser Operation
premiseOperation Object
o =
  [Parser Operation] -> Parser Operation
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ Key -> (Expression -> Expression -> Operation) -> Parser Operation
binary Key
"morph" Expression -> Expression -> Operation
OpMorph
    , Expression -> Operation
OpNormalize (Expression -> Operation) -> Parser Expression -> Parser Operation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"normalize"
    , Key -> (Expression -> Expression -> Operation) -> Parser Operation
binary Key
"evaluate" Expression -> Expression -> Operation
OpEvaluate
    , Key -> (Expression -> Expression -> Operation) -> Parser Operation
binary Key
"contextualize" Expression -> Expression -> Operation
OpContextualize
    , Key -> (Expression -> Expression -> Operation) -> Parser Operation
binary Key
"dataize" Expression -> Expression -> Operation
OpDataize
    ]
  where
    binary :: Key -> (Expression -> Expression -> Operation) -> Parser Operation
    binary :: Key -> (Expression -> Expression -> Operation) -> Parser Operation
binary Key
key Expression -> Expression -> Operation
verb = do
      [Value]
vals <- Object
o Object -> Key -> Parser [Value]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
key
      case [Value]
vals of
        [Value
expr, Value
second] -> Expression -> Expression -> Operation
verb (Expression -> Expression -> Operation)
-> Parser Expression -> Parser (Expression -> Operation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Expression
forall a. FromJSON a => Value -> Parser a
parseJSON Value
expr Parser (Expression -> Operation)
-> Parser Expression -> Parser Operation
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 Expression
forall a. FromJSON a => Value -> Parser a
parseJSON Value
second
        [Value]
_ -> String -> Parser Operation
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"'%s' expects exactly two arguments" (Key -> String
Key.toString Key
key))

parseLabel :: String -> Object -> Parser (Maybe String)
parseLabel :: String -> Object -> Parser (Maybe String)
parseLabel String
ruleName Object
o = do
  Maybe String
label' <- Object
o Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"label"
  if Maybe String
label' Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
ruleName
    then String -> Parser (Maybe String)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Maybe String))
-> String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$ String
"'label' is redundant when it equals 'name' (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ruleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"); drop it"
    else Maybe String -> Parser (Maybe String)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
label'

instance FromJSON MorphRule where
  parseJSON :: Value -> Parser MorphRule
parseJSON =
    String -> (Object -> Parser MorphRule) -> Value -> Parser MorphRule
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject
      String
"MorphRule"
      ( \Object
o -> do
          String
ruleName <- Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
          MorphRule
rule <-
            String
-> Maybe String
-> Expression
-> Expression
-> Expression
-> Maybe Condition
-> [Premise]
-> MorphRule
MorphRule String
ruleName
              (Maybe String
 -> Expression
 -> Expression
 -> Expression
 -> Maybe Condition
 -> [Premise]
 -> MorphRule)
-> Parser (Maybe String)
-> Parser
     (Expression
      -> Expression
      -> Expression
      -> Maybe Condition
      -> [Premise]
      -> MorphRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Object -> Parser (Maybe String)
parseLabel String
ruleName Object
o
              Parser
  (Expression
   -> Expression
   -> Expression
   -> Maybe Condition
   -> [Premise]
   -> MorphRule)
-> Parser Expression
-> Parser
     (Expression
      -> Expression -> Maybe Condition -> [Premise] -> MorphRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"match"
              Parser
  (Expression
   -> Expression -> Maybe Condition -> [Premise] -> MorphRule)
-> Parser Expression
-> Parser (Expression -> Maybe Condition -> [Premise] -> MorphRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"universe"
              Parser (Expression -> Maybe Condition -> [Premise] -> MorphRule)
-> Parser Expression
-> Parser (Maybe Condition -> [Premise] -> MorphRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"conclusion"
              Parser (Maybe Condition -> [Premise] -> MorphRule)
-> Parser (Maybe Condition) -> Parser ([Premise] -> MorphRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Condition)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"when"
              Parser ([Premise] -> MorphRule)
-> Parser [Premise] -> Parser MorphRule
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [Premise])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"premises" Parser (Maybe [Premise]) -> [Premise] -> Parser [Premise]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
          String -> String -> Expression -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless String
ruleName String
"conclusion" MorphRule
rule.nresult
          String -> String -> Maybe Condition -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless String
ruleName String
"when" MorphRule
rule.when
          String -> String -> [Premise] -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless String
ruleName String
"premises" MorphRule
rule.premises
          MorphRule -> Parser MorphRule
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MorphRule
rule
      )

instance FromJSON DataizeRule where
  parseJSON :: Value -> Parser DataizeRule
parseJSON =
    String
-> (Object -> Parser DataizeRule) -> Value -> Parser DataizeRule
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject
      String
"DataizeRule"
      ( \Object
o -> do
          String
ruleName <- Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
          DataizeRule
rule <-
            String
-> Maybe String
-> Expression
-> Expression
-> Bytes
-> Maybe Condition
-> [Premise]
-> DataizeRule
DataizeRule String
ruleName
              (Maybe String
 -> Expression
 -> Expression
 -> Bytes
 -> Maybe Condition
 -> [Premise]
 -> DataizeRule)
-> Parser (Maybe String)
-> Parser
     (Expression
      -> Expression
      -> Bytes
      -> Maybe Condition
      -> [Premise]
      -> DataizeRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Object -> Parser (Maybe String)
parseLabel String
ruleName Object
o
              Parser
  (Expression
   -> Expression
   -> Bytes
   -> Maybe Condition
   -> [Premise]
   -> DataizeRule)
-> Parser Expression
-> Parser
     (Expression
      -> Bytes -> Maybe Condition -> [Premise] -> DataizeRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"match"
              Parser
  (Expression
   -> Bytes -> Maybe Condition -> [Premise] -> DataizeRule)
-> Parser Expression
-> Parser (Bytes -> Maybe Condition -> [Premise] -> DataizeRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"universe"
              Parser (Bytes -> Maybe Condition -> [Premise] -> DataizeRule)
-> Parser Bytes
-> Parser (Maybe Condition -> [Premise] -> DataizeRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Bytes
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"conclusion"
              Parser (Maybe Condition -> [Premise] -> DataizeRule)
-> Parser (Maybe Condition) -> Parser ([Premise] -> DataizeRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Condition)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"when"
              Parser ([Premise] -> DataizeRule)
-> Parser [Premise] -> Parser DataizeRule
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [Premise])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"premises" Parser (Maybe [Premise]) -> [Premise] -> Parser [Premise]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
          String -> String -> Bytes -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless String
ruleName String
"conclusion" DataizeRule
rule.dresult
          String -> String -> Maybe Condition -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless String
ruleName String
"when" DataizeRule
rule.when
          String -> String -> [Premise] -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless String
ruleName String
"premises" DataizeRule
rule.premises
          DataizeRule -> Parser DataizeRule
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DataizeRule
rule
      )

instance FromJSON ContextualizeRule where
  parseJSON :: Value -> Parser ContextualizeRule
parseJSON =
    String
-> (Object -> Parser ContextualizeRule)
-> Value
-> Parser ContextualizeRule
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject
      String
"ContextualizeRule"
      ( \Object
o -> do
          String
ruleName <- Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
          ContextualizeRule
rule <-
            String
-> Maybe String
-> Expression
-> Expression
-> Expression
-> [Premise]
-> ContextualizeRule
ContextualizeRule String
ruleName
              (Maybe String
 -> Expression
 -> Expression
 -> Expression
 -> [Premise]
 -> ContextualizeRule)
-> Parser (Maybe String)
-> Parser
     (Expression
      -> Expression -> Expression -> [Premise] -> ContextualizeRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Object -> Parser (Maybe String)
parseLabel String
ruleName Object
o
              Parser
  (Expression
   -> Expression -> Expression -> [Premise] -> ContextualizeRule)
-> Parser Expression
-> Parser
     (Expression -> Expression -> [Premise] -> ContextualizeRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"match"
              Parser (Expression -> Expression -> [Premise] -> ContextualizeRule)
-> Parser Expression
-> Parser (Expression -> [Premise] -> ContextualizeRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"c-match"
              Parser (Expression -> [Premise] -> ContextualizeRule)
-> Parser Expression -> Parser ([Premise] -> ContextualizeRule)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Expression
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"c-result"
              Parser ([Premise] -> ContextualizeRule)
-> Parser [Premise] -> Parser ContextualizeRule
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe [Premise])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"premises" Parser (Maybe [Premise]) -> [Premise] -> Parser [Premise]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
          String -> String -> Expression -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless String
ruleName String
"c-result" ContextualizeRule
rule.cresult
          String -> String -> [Premise] -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless String
ruleName String
"premises" ContextualizeRule
rule.premises
          ContextualizeRule -> Parser ContextualizeRule
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContextualizeRule
rule
      )

morphingRules :: [MorphRule]
{-# NOINLINE morphingRules #-}
morphingRules :: [MorphRule]
morphingRules = ((String, ByteString) -> MorphRule)
-> [(String, ByteString)] -> [MorphRule]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> MorphRule
forall a. FromJSON a => (String, ByteString) -> a
decodeRule $(embedDir "resources/morphing")

dataizationRules :: [DataizeRule]
{-# NOINLINE dataizationRules #-}
dataizationRules :: [DataizeRule]
dataizationRules = ((String, ByteString) -> DataizeRule)
-> [(String, ByteString)] -> [DataizeRule]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> DataizeRule
forall a. FromJSON a => (String, ByteString) -> a
decodeRule $(embedDir "resources/dataization")

contextualizationRules :: [ContextualizeRule]
{-# NOINLINE contextualizationRules #-}
contextualizationRules :: [ContextualizeRule]
contextualizationRules = ((String, ByteString) -> ContextualizeRule)
-> [(String, ByteString)] -> [ContextualizeRule]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> ContextualizeRule
forall a. FromJSON a => (String, ByteString) -> a
decodeRule $(embedDir "resources/contextualization")