phino-0.0.162: src/Yaml.hs

{-# 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.Conduit ((.|))
import qualified Data.Conduit.List as CL
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), decodeHelper_)
import GHC.Generics (Generic)
import Metas
import Parser
import Slots
import qualified Text.Libyaml as Libyaml
import Text.Printf (printf)
import Text.Regex.PCRE ((=~))

shiftYamlError :: String -> String
shiftYamlError msg =
  case (msg =~ ("^YAML parse exception at line ([0-9]+), column ([0-9]+)([:,])" :: String)) :: (String, String, String, [String]) of
    (before, _, after, [ln, col, sep]) ->
      printf "%sYAML parse exception at line %d, column %d%s%s" before (read ln + 1 :: Int) (read col + 1 :: Int) sep after
    _ -> msg

validateYamlObject :: (MonadFail a) => Object -> [String] -> a ()
validateYamlObject v keys
  | length current > 1 = fail ("Exactly one condition type is expected, when multiple condition types specified: " ++ show current)
  | null present = fail (printf "Unknown condition type '%s', expected one of: %s" (show current) (show keys))
  | otherwise = pure ()
  where
    present :: [Key.Key]
    present = filter (`KeyMap.member` v) (map Key.fromString keys)
    current :: [Key.Key]
    current = KeyMap.keys v

validateKnownYamlKeys :: (MonadFail a) => Object -> [String] -> a ()
validateKnownYamlKeys v keys =
  let unknown = filter (\key -> key `notElem` map Key.fromString keys) (KeyMap.keys v)
   in case unknown of
        [] -> pure ()
        key : _ -> fail (printf "Unknown key '%s', expected one of: %s" (show key) (show keys))

parseJSON' :: String -> (String -> Either String a) -> Value -> Parser a
parseJSON' nm func =
  withText
    nm
    ( \txt -> case func (unpack txt) of
        Left err -> fail err
        Right parsed -> pure parsed
    )

instance FromJSON Attribute where
  parseJSON =
    withText
      "Attribute"
      ( \txt -> case unpack txt of
          "λ" -> pure AtLambda
          "Δ" -> pure AtDelta
          other -> case parseAttribute other of
            Left err -> fail err
            Right attr -> pure attr
      )

instance FromJSON Alpha where
  parseJSON = parseJSON' "Alpha" parseAlpha

instance FromJSON Bytes where
  parseJSON = parseJSON' "Bytes" parseBytes

instance FromJSON Expression where
  parseJSON = parseJSON' "Expression" parseExpression

instance FromJSON Binding where
  parseJSON = parseJSON' "Binding" parseBinding

instance FromJSON Number where
  parseJSON v = case v of
    Object o -> do
      validateYamlObject o ["length", "domain"]
      asum
        [ Length <$> o .: "length"
        , Domain <$> o .: "domain"
        ]
    Number num
      | toRational (round num :: Integer) /= toRational num -> fail (printf "Expected an integer, got a fractional number %s" (show num))
      | (round num :: Integer) < toInteger (minBound :: Int) || (round num :: Integer) > toInteger (maxBound :: Int) -> fail (printf "The literal %s does not fit into Int" (show num))
      | otherwise -> pure (Literal (round num))
    String txt -> case parseIndex (unpack txt) of
      Right (Right mt) -> pure (MetaIndex mt)
      Right (Left slot) -> pure (AnyIndex slot)
      Left err -> fail err
    _ ->
      fail "Expected a numerable expression (object, number or index meta)"

instance FromJSON Comparable where
  parseJSON (Number num)
    | isInteger num && ((round num :: Integer) < toInteger (minBound :: Int) || (round num :: Integer) > toInteger (maxBound :: Int)) =
        fail (printf "The literal %s does not fit into Int" (show num))
  parseJSON v@(Number _) = CmpNum <$> parseJSON v
  parseJSON v@(Object _) = CmpNum <$> parseJSON v
  parseJSON v@(String _) =
    foldr1
      (<|>)
      [ CmpAttr <$> parseJSON v
      , CmpNum <$> parseJSON v
      , CmpExpr <$> parseJSON v
      ]
  parseJSON _ = fail "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 = withObject "Condition" $ \v -> do
    cond <- parseCondition v
    cond <$ either fail pure (wellCompared cond)

parseCondition :: Object -> Parser Condition
parseCondition v = do
  validateYamlObject v ["and", "or", "not", "nf", "absolute", "eq", "gt", "in", "matches", "part-of", "disjoint", "formation"]
  case KeyMap.keys v of
    [key] -> case Key.toString key of
      "and" -> do
        conds <- v .: "and"
        if null conds
          then fail "The 'and' condition requires at least one element"
          else pure (And conds)
      "or" -> do
        conds <- v .: "or"
        if null conds
          then fail "The 'or' condition requires at least one element"
          else pure (Or conds)
      "not" -> Not <$> v .: "not"
      "nf" -> NF <$> v .: "nf"
      "absolute" -> Absolute <$> v .: "absolute"
      "formation" -> IsFormation <$> v .: "formation"
      "disjoint" -> do
        vals <- v .: "disjoint"
        case vals of
          [attrs_, bds_] -> Disjoint <$> parseJSON attrs_ <*> parseJSON bds_
          _ -> fail "'disjoint' expects exactly two arguments"
      "eq" -> do
        vals <- v .: "eq"
        case vals of
          [left_, right_] -> Eq <$> parseJSON left_ <*> parseJSON right_
          _ -> fail "'eq' expects exactly two arguments"
      "gt" -> do
        vals <- v .: "gt"
        case vals of
          [left_, right_] -> Gt <$> parseJSON left_ <*> parseJSON right_
          _ -> fail "'gt' expects exactly two arguments"
      "in" -> do
        vals <- v .: "in"
        case vals of
          [attrs_, bds_] -> In <$> several attrs_ <*> several bds_
          _ -> fail "'in' expects exactly two arguments"
      "matches" -> do
        vals <- v .: "matches"
        case vals of
          [pat, ex] -> Matches <$> parseJSON pat <*> parseJSON ex
          _ -> fail "'matches' expects exactly two arguments"
      "part-of" -> do
        vals <- v .: "part-of"
        case vals of
          [ex, bd] -> PartOf <$> parseJSON ex <*> parseJSON bd
          _ -> fail "'part-of' expects exactly two arguments"
      _ -> fail "Unknown condition type"
    _ -> fail "Exactly one condition type is expected"
  where
    several :: FromJSON a => Value -> Parser [a]
    several val = parseJSON val <|> (pure <$> parseJSON val)

kindOf :: Comparable -> String
kindOf (CmpNum _) = "a number"
kindOf (CmpAttr _) = "an attribute"
kindOf (CmpExpr _) = "an expression"

wellCompared :: Condition -> Either String ()
wellCompared = \case
  And conds -> mapM_ wellCompared conds
  Or conds -> mapM_ wellCompared conds
  Not cond -> wellCompared cond
  Eq left right
    | kindOf left == kindOf right -> Right ()
    | otherwise -> mismatch "eq" "two numbers, two attributes or two expressions" left right
  Gt left right
    | kindOf left == "a number" && kindOf right == "a number" -> Right ()
    | otherwise -> mismatch "gt" "two numbers" left right
  _ -> Right ()
  where
    mismatch :: String -> String -> Comparable -> Comparable -> Either String ()
    mismatch verb allowed left right =
      Left (printf "The '%s' condition compares %s with %s, while it can compare only %s" verb (kindOf left) (kindOf right) allowed)

instance FromJSON ExtraArgument where
  parseJSON v@(String _) =
    foldr1
      (<|>)
      [ ArgAttribute <$> parseJSON v
      , ArgBinding <$> parseJSON v
      , ArgBytes <$> parseJSON v
      , ArgExpression <$> parseJSON v
      ]
  parseJSON _ = fail "An argument of a 'where' function is a string holding an attribute, a binding, bytes or an expression"

instance FromJSON Extra where
  parseJSON =
    withObject
      "Extra"
      ( \o -> do
          validateKnownYamlKeys o ["meta", "function", "args"]
          Extra
            <$> o .: "meta"
            <*> o .: "function"
            <*> o .:? "args" .!= []
      )

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

data Number
  = MetaIndex Text
  | AnyIndex Slot
  | Length Binding
  | Domain Binding
  | Literal Int
  deriving (Eq, Generic, Show)

data Comparable
  = CmpAttr Attribute
  | CmpNum Number
  | CmpExpr Expression
  deriving (Eq, Generic, 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 (Eq, Generic, Show)

data ExtraArgument
  = ArgAttribute Attribute
  | ArgExpression Expression
  | ArgBinding Binding
  | ArgBytes Bytes
  deriving (Generic, Show)

data Extra = Extra
  { meta :: ExtraArgument
  , function :: String
  , args :: [ExtraArgument]
  }
  deriving (Generic, Show)

data Rule = Rule
  { name :: String
  , label :: Maybe String
  , description :: Maybe String
  , pattern :: Expression
  , result :: Expression
  , when :: Maybe Condition
  , where_ :: Maybe [Extra]
  , having :: Maybe Condition
  }
  deriving (Generic, Show)

instance Slots Condition where
  slots (And conds) = slots conds
  slots (Or conds) = slots conds
  slots (Not cond) = slots cond
  slots (In attrs bds) = slots attrs ++ slots bds
  slots (Eq left right) = slots left ++ slots right
  slots (Gt left right) = slots left ++ slots right
  slots (NF expr) = slots expr
  slots (Absolute expr) = slots expr
  slots (Matches _ expr) = slots expr
  slots (PartOf expr bd) = slots expr ++ slots bd
  slots (Disjoint attrs bds) = slots attrs ++ slots bds
  slots (IsFormation expr) = slots expr

instance Slots Comparable where
  slots (CmpAttr attr) = slots attr
  slots (CmpNum num) = slots num
  slots (CmpExpr expr) = slots expr

instance Slots Number where
  slots (AnyIndex slot) = [slot]
  slots (Length bd) = slots bd
  slots (Domain bd) = slots bd
  slots (MetaIndex _) = []
  slots (Literal _) = []

instance Slots ExtraArgument where
  slots (ArgAttribute attr) = slots attr
  slots (ArgExpression expr) = slots expr
  slots (ArgBinding bd) = slots bd
  slots (ArgBytes bts) = slots bts

instance Slots Extra where
  slots extra = slots extra.meta ++ slots extra.args

instance Slots Premise where
  slots premise = slots premise.operation

instance Slots Operation where
  slots (OpMorph expr universe) = slots expr ++ slots universe
  slots (OpNormalize expr) = slots expr
  slots (OpEvaluate expr universe) = slots expr ++ slots universe
  slots (OpContextualize expr context) = slots expr ++ slots context
  slots (OpDataize expr universe) = slots expr ++ slots universe

instance Metas Condition where
  metas (And conds) = metas conds
  metas (Or conds) = metas conds
  metas (Not cond) = metas cond
  metas (In attrs bds) = metas attrs ++ metas bds
  metas (Eq left right) = metas left ++ metas right
  metas (Gt left right) = metas left ++ metas right
  metas (NF expr) = metas expr
  metas (Absolute expr) = metas expr
  metas (Matches _ expr) = metas expr
  metas (PartOf expr bd) = metas expr ++ metas bd
  metas (Disjoint attrs bds) = metas attrs ++ metas bds
  metas (IsFormation expr) = metas expr
  bare names (And conds) = And (bare names conds)
  bare names (Or conds) = Or (bare names conds)
  bare names (Not cond) = Not (bare names cond)
  bare names (In attrs bds) = In (bare names attrs) (bare names bds)
  bare names (Eq left right) = Eq (bare names left) (bare names right)
  bare names (Gt left right) = Gt (bare names left) (bare names right)
  bare names (NF expr) = NF (bare names expr)
  bare names (Absolute expr) = Absolute (bare names expr)
  bare names (Matches regex expr) = Matches regex (bare names expr)
  bare names (PartOf expr bd) = PartOf (bare names expr) (bare names bd)
  bare names (Disjoint attrs bds) = Disjoint (bare names attrs) (bare names bds)
  bare names (IsFormation expr) = IsFormation (bare names expr)

instance Metas Comparable where
  metas (CmpAttr attr) = metas attr
  metas (CmpNum num) = metas num
  metas (CmpExpr expr) = metas expr
  bare names (CmpAttr attr) = CmpAttr (bare names attr)
  bare names (CmpNum num) = CmpNum (bare names num)
  bare names (CmpExpr expr) = CmpExpr (bare names expr)

instance Metas Number where
  metas (MetaIndex named) = metas named
  metas (AnyIndex slot) = metas slot
  metas (Length bd) = metas bd
  metas (Domain bd) = metas bd
  metas (Literal _) = []
  bare names (MetaIndex named) = MetaIndex (bare names named)
  bare names (Length bd) = Length (bare names bd)
  bare names (Domain bd) = Domain (bare names bd)
  bare _ num = num

instance Metas ExtraArgument where
  metas (ArgAttribute attr) = metas attr
  metas (ArgExpression expr) = metas expr
  metas (ArgBinding bd) = metas bd
  metas (ArgBytes bts) = metas bts
  bare names (ArgAttribute attr) = ArgAttribute (bare names attr)
  bare names (ArgExpression expr) = ArgExpression (bare names expr)
  bare names (ArgBinding bd) = ArgBinding (bare names bd)
  bare names (ArgBytes bts) = ArgBytes (bare names bts)

instance Metas Extra where
  metas extra = metas extra.meta ++ metas extra.args
  bare names extra = extra{meta = bare names extra.meta, args = bare names extra.args}

instance Metas Premise where
  metas premise = metas premise.result ++ metas premise.operation
  bare names premise = premise{result = bare names premise.result, operation = bare names premise.operation}

instance Metas Operation where
  metas (OpMorph expr universe) = metas expr ++ metas universe
  metas (OpNormalize expr) = metas expr
  metas (OpEvaluate expr universe) = metas expr ++ metas universe
  metas (OpContextualize expr context) = metas expr ++ metas context
  metas (OpDataize expr universe) = metas expr ++ metas universe
  bare names (OpMorph expr universe) = OpMorph (bare names expr) (bare names universe)
  bare names (OpNormalize expr) = OpNormalize (bare names expr)
  bare names (OpEvaluate expr universe) = OpEvaluate (bare names expr) (bare names universe)
  bare names (OpContextualize expr context) = OpContextualize (bare names expr) (bare names context)
  bare names (OpDataize expr universe) = OpDataize (bare names expr) (bare names universe)

instance Metas Rule where
  metas rule = metas rule.pattern ++ metas rule.result ++ metas rule.when ++ metas rule.having ++ metas rule.where_
  bare names 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 rule = metas rule.match ++ metas rule.ematch ++ metas rule.nresult ++ metas rule.when ++ metas rule.premises
  bare names rule =
    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 rule = metas rule.match ++ metas rule.ematch ++ metas rule.dresult ++ metas rule.when ++ metas rule.premises
  bare names rule =
    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 rule = metas rule.match ++ metas rule.cmatch ++ metas rule.cresult ++ metas rule.premises
  bare names rule =
    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 rule (Object fields)
  | KeyMap.member "e-match" fields = fail (printf "The rule '%s' carries an 'e-match', which only a morphing or a dataization rule may" rule)
universeless _ _ = pure ()

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

decodeRule :: (FromJSON a) => (FilePath, BS.ByteString) -> a
decodeRule (path, bs) = case Yaml.decodeEither' bs of
  Right rule -> rule
  Left err -> error $ "YAML parse error in " ++ path ++ ": " ++ show err

normalizationRules :: [Rule]
{-# NOINLINE normalizationRules #-}
normalizationRules = map decodeRule $(embedDir "resources/normalize")

yamlRule :: FilePath -> IO Rule
yamlRule path = do
  decoded <- decodeHelper_ (Libyaml.decodeFile path .| CL.map worded)
  case decoded of
    Left err -> throwIO err
    Right (warnings, rule) -> rule <$ mapM_ reportDuplicateKey warnings
  where
    worded :: Libyaml.Event -> Libyaml.Event
    worded (Libyaml.EventScalar value Libyaml.NoTag style anchor)
      | value `elem` spelled = Libyaml.EventScalar value Libyaml.StrTag style anchor
    worded event = event
    spelled :: [BS.ByteString]
    spelled = ["y", "Y", "yes", "Yes", "YES", "n", "N", "no", "No", "NO", "on", "On", "ON", "off", "Off", "OFF"]
    reportDuplicateKey :: Warning -> IO ()
    reportDuplicateKey (DuplicateKey jsonPath) =
      fail (printf "The key '%s' is repeated in the rule file '%s', only the last value is kept" (formatRelativePath jsonPath) path)

data Premise = Premise
  { result :: Text
  , operation :: Operation
  }
  deriving (Eq, Generic, Show)

data Operation
  = OpMorph Expression Expression
  | OpNormalize Expression
  | OpEvaluate Expression Expression
  | OpContextualize Expression Expression
  | OpDataize Expression Expression
  deriving (Eq, Generic, Show)

data MorphRule = MorphRule
  { name :: String
  , label :: Maybe String
  , match :: Expression
  , ematch :: Expression
  , nresult :: Expression
  , when :: Maybe Condition
  , premises :: [Premise]
  }
  deriving (Generic, Show)

data DataizeRule = DataizeRule
  { name :: String
  , label :: Maybe String
  , match :: Expression
  , ematch :: Expression
  , dresult :: Bytes
  , when :: Maybe Condition
  , premises :: [Premise]
  }
  deriving (Generic, Show)

data ContextualizeRule = ContextualizeRule
  { name :: String
  , label :: Maybe String
  , match :: Expression
  , cmatch :: Expression
  , cresult :: Expression
  , premises :: [Premise]
  }
  deriving (Generic, Show)

instance FromJSON Premise where
  parseJSON =
    withObject
      "Premise"
      (\o -> Premise <$> premiseResult o <*> premiseOperation o)

premiseResult :: Object -> Parser Text
premiseResult o = do
  expr <- o .:? "n-result"
  case expr of
    Just (ExMeta metaName) -> pure metaName
    Just (ExAny _) -> fail "an anonymous 'n-result' meta cannot be referenced"
    Just _ -> fail "'n-result' must be an expression meta"
    Nothing -> do
      bytes <- o .:? "d-result"
      case bytes of
        Just (BtMeta metaName) -> pure metaName
        Just (BtAny _) -> fail "an anonymous 'd-result' meta cannot be referenced"
        Just _ -> fail "'d-result' must be a bytes meta"
        Nothing -> fail "a premise needs an 'n-result' or 'd-result' meta"

premiseOperation :: Object -> Parser Operation
premiseOperation o =
  asum
    [ binary "morph" OpMorph
    , OpNormalize <$> o .: "normalize"
    , binary "evaluate" OpEvaluate
    , binary "contextualize" OpContextualize
    , binary "dataize" OpDataize
    ]
  where
    binary :: Key -> (Expression -> Expression -> Operation) -> Parser Operation
    binary key verb = do
      vals <- o .: key
      case vals of
        [expr, second] -> verb <$> parseJSON expr <*> parseJSON second
        _ -> fail (printf "'%s' expects exactly two arguments" (Key.toString key))

parseLabel :: String -> Object -> Parser (Maybe String)
parseLabel ruleName o = do
  label' <- o .:? "label"
  if label' == Just ruleName
    then fail $ "'label' is redundant when it equals 'name' (" ++ ruleName ++ "); drop it"
    else pure label'

instance FromJSON MorphRule where
  parseJSON =
    withObject
      "MorphRule"
      ( \o -> do
          ruleName <- o .: "name"
          rule <-
            MorphRule ruleName
              <$> parseLabel ruleName o
              <*> o .: "match"
              <*> o .: "universe"
              <*> o .: "conclusion"
              <*> o .:? "when"
              <*> o .:? "premises" .!= []
          referenceless ruleName "conclusion" rule.nresult
          referenceless ruleName "when" rule.when
          referenceless ruleName "premises" rule.premises
          pure rule
      )

instance FromJSON DataizeRule where
  parseJSON =
    withObject
      "DataizeRule"
      ( \o -> do
          ruleName <- o .: "name"
          rule <-
            DataizeRule ruleName
              <$> parseLabel ruleName o
              <*> o .: "match"
              <*> o .: "universe"
              <*> o .: "conclusion"
              <*> o .:? "when"
              <*> o .:? "premises" .!= []
          referenceless ruleName "conclusion" rule.dresult
          referenceless ruleName "when" rule.when
          referenceless ruleName "premises" rule.premises
          pure rule
      )

instance FromJSON ContextualizeRule where
  parseJSON =
    withObject
      "ContextualizeRule"
      ( \o -> do
          ruleName <- o .: "name"
          rule <-
            ContextualizeRule ruleName
              <$> parseLabel ruleName o
              <*> o .: "match"
              <*> o .: "c-match"
              <*> o .: "c-result"
              <*> o .:? "premises" .!= []
          referenceless ruleName "c-result" rule.cresult
          referenceless ruleName "premises" rule.premises
          pure rule
      )

morphingRules :: [MorphRule]
{-# NOINLINE morphingRules #-}
morphingRules = map decodeRule $(embedDir "resources/morphing")

dataizationRules :: [DataizeRule]
{-# NOINLINE dataizationRules #-}
dataizationRules = map decodeRule $(embedDir "resources/dataization")

contextualizationRules :: [ContextualizeRule]
{-# NOINLINE contextualizationRules #-}
contextualizationRules = map decodeRule $(embedDir "resources/contextualization")