{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

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

module Lambdas
  ( Ending (..)
  , Lambda (..)
  , LambdaException (..)
  , Lambdas
  , Line (..)
  , Meta (..)
  , cast
  , emptyLambdas
  , matched
  , minted
  , readLambdas
  , rewritten
  , sized
  , stayed
  , symbolized
  , taken
  , thrown
  )
where

import AST
import Builder (buildExpressionThrows)
import Control.Exception (Exception, throwIO)
import Control.Monad ((<$!>))
import Control.Monad.Trans.State.Strict (State, runState, state)
import Data.Aeson (FromJSON (parseJSON), Key, Object, withObject, (.!=), (.:?))
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Aeson.Types (JSONPathElement (Key), (<?>))
import Data.Char (isDigit)
import Data.Either (partitionEithers)
import Data.List (find, sortOn)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Yaml as Yaml
import Language (Language, language, shared)
import Logger (logDebug)
import Matcher (substEmpty)
import Metas (Metas (metas))
import Parser (parseBinding, parseBytes, parseExpression)
import Rule (RuleContext, matchExpressionWithRule')
import Slots (Slots (slots))
import Text.Printf (printf)
import Text.Regex.PCRE (matchTest)
import Text.Regex.PCRE.ByteString (Regex, compUTF8, compile, execBlank)
import Yaml (referenceless)
import qualified Yaml as Y

data Meta = Meta
  { Meta -> Text
_spelling :: Text
  , Meta -> Text
_name :: Text
  }

data Line
  = Dataized Meta Meta
  | Morphed Meta Meta
  | Undressed Meta Meta
  | Evaluated Meta Meta
  | Deferred Meta Meta
  | Stayed Meta Meta
  | Rewritten Meta Meta [Y.Rule]
  | Symbolized Meta Meta
  | Cast Meta Meta Meta Meta

data Ending
  = Answering Expression
  | Joining (Either Meta Expression) Expression Expression (Maybe Function)

data Lambda = Lambda
  { Lambda -> Text
_key :: Text
  , Lambda -> [(Meta, Expression)]
_dataized :: [(Meta, Expression)]
  , Lambda -> [(Meta, Expression)]
_morphed :: [(Meta, Expression)]
  , Lambda -> [(Meta, Expression)]
_undressed :: [(Meta, Expression)]
  , Lambda -> [Line]
_lines :: [Line]
  , Lambda -> [Text]
_terminators :: [Text]
  , Lambda -> Ending
_ending :: Ending
  }

newtype Lambdas = Lambdas [(Regex, Lambda)]

data LambdaException
  = BrokenLambdas FilePath String
  deriving anyclass (Show LambdaException
Typeable LambdaException
(Typeable LambdaException, Show LambdaException) =>
(LambdaException -> SomeException)
-> (SomeException -> Maybe LambdaException)
-> (LambdaException -> String)
-> Exception LambdaException
SomeException -> Maybe LambdaException
LambdaException -> String
LambdaException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: LambdaException -> SomeException
toException :: LambdaException -> SomeException
$cfromException :: SomeException -> Maybe LambdaException
fromException :: SomeException -> Maybe LambdaException
$cdisplayException :: LambdaException -> String
displayException :: LambdaException -> String
Exception)

instance Show LambdaException where
  show :: LambdaException -> String
show (BrokenLambdas String
file String
failure) =
    String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The λ functions of '%s' cannot be read: %s" String
file String
failure

instance FromJSON Lambda where
  parseJSON :: Value -> Parser Lambda
parseJSON = String -> (Object -> Parser Lambda) -> Value -> Parser Lambda
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Lambda" ((Object -> Parser Lambda) -> Value -> Parser Lambda)
-> (Object -> Parser Lambda) -> Value -> Parser Lambda
forall a b. (a -> b) -> a -> b
$ \Object
entry -> do
    Text
key <- Object
entry Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"λ" Parser (Maybe Text) -> (Maybe Text -> Parser Text) -> Parser Text
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser Text -> (Text -> Parser Text) -> Maybe Text -> Parser Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Text
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The entry has no 'λ' key") Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    String -> Object -> Parser ()
unknown (Text -> String
T.unpack Text
key) Object
entry
    ([(Meta, Expression)]
dataized, [Line]
weighing) <- [Either (Meta, Expression) Line] -> ([(Meta, Expression)], [Line])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Meta, Expression) Line]
 -> ([(Meta, Expression)], [Line]))
-> Parser [Either (Meta, Expression) Line]
-> Parser ([(Meta, Expression)], [Line])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (Text -> Parser Meta)
-> (Meta -> Meta -> Line)
-> Object
-> Key
-> Parser [Either (Meta, Expression) Line]
reductions Text
key Text -> Parser Meta
bytesMeta Meta -> Meta -> Line
Dataized Object
entry Key
"dataize"
    Ending
ending <- String -> [(Meta, Expression)] -> Object -> Parser Ending
concluded (Text -> String
T.unpack Text
key) [(Meta, Expression)]
dataized Object
entry
    ([(Meta, Expression)]
morphed, [Line]
reading) <- [Either (Meta, Expression) Line] -> ([(Meta, Expression)], [Line])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Meta, Expression) Line]
 -> ([(Meta, Expression)], [Line]))
-> Parser [Either (Meta, Expression) Line]
-> Parser ([(Meta, Expression)], [Line])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (Text -> Parser Meta)
-> (Meta -> Meta -> Line)
-> Object
-> Key
-> Parser [Either (Meta, Expression) Line]
reductions Text
key Text -> Parser Meta
expressionMeta Meta -> Meta -> Line
Morphed Object
entry Key
"morph"
    ([(Meta, Expression)]
undressed, [Line]
peeling) <- [Either (Meta, Expression) Line] -> ([(Meta, Expression)], [Line])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Meta, Expression) Line]
 -> ([(Meta, Expression)], [Line]))
-> Parser [Either (Meta, Expression) Line]
-> Parser ([(Meta, Expression)], [Line])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (Text -> Parser Meta)
-> (Meta -> Meta -> Line)
-> Object
-> Key
-> Parser [Either (Meta, Expression) Line]
reductions Text
key Text -> Parser Meta
expressionMeta Meta -> Meta -> Line
Undressed Object
entry Key
"undress"
    Lambda
lambda <-
      Text
-> [(Meta, Expression)]
-> [(Meta, Expression)]
-> [(Meta, Expression)]
-> [Line]
-> [Text]
-> Ending
-> Lambda
Lambda Text
key [(Meta, Expression)]
dataized [(Meta, Expression)]
morphed [(Meta, Expression)]
undressed
        ([Line] -> [Text] -> Ending -> Lambda)
-> Parser [Line] -> Parser ([Text] -> Ending -> Lambda)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Object -> Parser [Line]
written (Text -> String
T.unpack Text
key) Object
entry Parser [Line] -> ([Line] -> Parser [Line]) -> Parser [Line]
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> [Text] -> [Line] -> Parser [Line]
ordered (Text -> String
T.unpack Text
key) (((Meta, Expression) -> Text) -> [(Meta, Expression)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Meta -> Text
_name (Meta -> Text)
-> ((Meta, Expression) -> Meta) -> (Meta, Expression) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Meta, Expression) -> Meta
forall a b. (a, b) -> a
fst) ([(Meta, Expression)]
morphed [(Meta, Expression)]
-> [(Meta, Expression)] -> [(Meta, Expression)]
forall a. [a] -> [a] -> [a]
++ [(Meta, Expression)]
undressed)) ([Line] -> Parser [Line])
-> ([Line] -> [Line]) -> [Line] -> Parser [Line]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Line]
weighing [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++ [Line]
reading [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++ [Line]
peeling) [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++))
        Parser ([Text] -> Ending -> Lambda)
-> Parser [Text] -> Parser (Ending -> Lambda)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
entry Object -> Key -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"terminators" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
        Parser (Ending -> Lambda) -> Parser Ending -> Parser Lambda
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ending -> Parser Ending
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ending
ending
    String -> Lambda -> Parser ()
once (Text -> String
T.unpack Text
key) Lambda
lambda
    ((Meta, Expression) -> Parser ())
-> [(Meta, Expression)] -> Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> String -> (Meta, Expression) -> Parser ()
metaless (Text -> String
T.unpack Text
key) String
"dataize" String
"a path from '$' or a meta alone") Lambda
lambda._dataized
    ((Meta, Expression) -> Parser ())
-> [(Meta, Expression)] -> Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> String -> (Meta, Expression) -> Parser ()
metaless (Text -> String
T.unpack Text
key) String
"morph" String
"a path from '$' or a meta alone") Lambda
lambda._morphed
    ((Meta, Expression) -> Parser ())
-> [(Meta, Expression)] -> Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> String -> (Meta, Expression) -> Parser ()
metaless (Text -> String
T.unpack Text
key) String
"undress" String
"a path from '$' or a meta alone") Lambda
lambda._undressed
    String -> Lambda -> Parser ()
answered (Text -> String
T.unpack Text
key) Lambda
lambda
    Lambda -> Parser Lambda
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lambda
lambda
    where
      unknown :: String -> Object -> Yaml.Parser ()
      unknown :: String -> Object -> Parser ()
unknown String
key Object
entry = 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) ((Key -> Text) -> [Key] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Text
Key.toText (Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
entry)) of
        [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Text
name : [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 key '%s' of λ function '%s' is none of the keys an entry reads: %s" (Text -> String
T.unpack Text
name) String
key (Text -> String
T.unpack (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
known)))
        where
          known :: [Text]
          known :: [Text]
known = [Text
"λ", Text
"dataize", Text
"morph", Text
"undress", Text
"evaluate", Text
"defer", Text
"stay", Text
"rewrite", Text
"symbolize", Text
"cast", Text
"join", Text
"terminators", Text
"𝑛"]
      concluded :: String -> [(Meta, Expression)] -> Object -> Yaml.Parser Ending
      concluded :: String -> [(Meta, Expression)] -> Object -> Parser Ending
concluded String
key [(Meta, Expression)]
dataized Object
entry = do
        Maybe Expression
answer <- Object
entry Object -> Key -> Parser (Maybe Expression)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"𝑛"
        Maybe Object
block <- Object
entry Object -> Key -> Parser (Maybe Object)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"join"
        case (Maybe Expression
answer, Maybe Object
block) of
          (Maybe Expression
Nothing, Maybe Object
Nothing) -> String -> Parser Ending
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 entry of λ function '%s' has neither an '𝑛' key nor a 'join' block" String
key)
          (Just Expression
_, Just Object
_) -> String -> Parser Ending
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 entry of λ function '%s' has both an '𝑛' key and a 'join' block, while a join answers the term it joins" String
key)
          (Just Expression
term, Maybe Object
Nothing) -> Expression -> Ending
Answering Expression
term Ending -> Parser () -> Parser Ending
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Expression -> Parser ()
sigmas String
key Expression
term Parser Ending -> Parser () -> Parser Ending
forall a b. Parser a -> Parser b -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Expression -> Parser ()
dataless String
key Expression
term
          (Maybe Expression
Nothing, Just Object
joint) -> String -> [(Meta, Expression)] -> Object -> Parser Ending
joining String
key [(Meta, Expression)]
dataized Object
joint
      joining :: String -> [(Meta, Expression)] -> Object -> Yaml.Parser Ending
      joining :: String -> [(Meta, Expression)] -> Object -> Parser Ending
joining String
key [(Meta, Expression)]
dataized Object
block = do
        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
"on", Text
"left", Text
"right", Text
"otherwise"]) ((Key -> Text) -> [Key] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Text
Key.toText (Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
block)) of
          [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Text
name : [Text]
_ -> 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 key '%s' of the 'join' block of λ function '%s' is none of its keys: on, left, right, otherwise" (Text -> String
T.unpack Text
name) String
key)
        Either Meta Expression
on <- Key -> Parser Text
forall value. FromJSON value => Key -> Parser value
required Key
"on" Parser Text
-> (Text -> Parser (Either Meta Expression))
-> Parser (Either Meta Expression)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Parser (Either Meta Expression)
condition
        Either Meta Expression
-> Expression -> Expression -> Maybe Function -> Ending
Joining Either Meta Expression
on (Expression -> Expression -> Maybe Function -> Ending)
-> Parser Expression
-> Parser (Expression -> Maybe Function -> Ending)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Key -> Parser Expression
forall value. FromJSON value => Key -> Parser value
required Key
"left" Parser Expression
-> (Expression -> Parser Expression) -> Parser Expression
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Expression -> Parser Expression
side String
"left") Parser (Expression -> Maybe Function -> Ending)
-> Parser Expression -> Parser (Maybe Function -> Ending)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Key -> Parser Expression
forall value. FromJSON value => Key -> Parser value
required Key
"right" Parser Expression
-> (Expression -> Parser Expression) -> Parser Expression
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Expression -> Parser Expression
side String
"right") Parser (Maybe Function -> Ending)
-> Parser (Maybe Function) -> Parser Ending
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
block Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"otherwise" Parser (Maybe Text)
-> (Maybe Text -> Parser (Maybe Function))
-> Parser (Maybe Function)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> Parser Function) -> Maybe Text -> Parser (Maybe Function)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Text -> Parser Function
fallback)
        where
          required :: FromJSON value => Key -> Yaml.Parser value
          required :: forall value. FromJSON value => Key -> Parser value
required Key
name = Object
block Object -> Key -> Parser (Maybe value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
name Parser (Maybe value)
-> (Maybe value -> Parser value) -> Parser value
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser value
-> (value -> Parser value) -> Maybe value -> Parser value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser value
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 'join' block of λ function '%s' has no '%s' key" String
key (Key -> String
Key.toString Key
name))) value -> Parser value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          condition :: Text -> Yaml.Parser (Either Meta Expression)
          condition :: Text -> Parser (Either Meta Expression)
condition Text
spelling = case (String -> Either String Bytes
parseBytes (Text -> String
T.unpack Text
spelling), String -> Either String Expression
parseExpression (Text -> String
T.unpack Text
spelling)) of
            (Right (BtMeta Text
name), Either String Expression
_) | Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Meta, Expression) -> Text) -> [(Meta, Expression)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Meta -> Text
_name (Meta -> Text)
-> ((Meta, Expression) -> Meta) -> (Meta, Expression) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Meta, Expression) -> Meta
forall a b. (a, b) -> a
fst) [(Meta, Expression)]
dataized -> Either Meta Expression -> Parser (Either Meta Expression)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Meta -> Either Meta Expression
forall a b. a -> Either a b
Left (Text -> Text -> Meta
Meta Text
spelling Text
name))
            (Either String Bytes
_, Right Expression
path) | Expression -> Bool
pathed Expression
path -> Either Meta Expression -> Parser (Either Meta Expression)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Either Meta Expression
forall a b. b -> Either a b
Right Expression
path)
            (Either String Bytes, Either String Expression)
_ -> String -> Parser (Either Meta Expression)
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 'on' of the 'join' block of λ function '%s' is '%s', while it must name a bytes meta of 'dataize' reading a path from '$', such as '𝛿1', or be a path from '$', such as '$.on'" String
key (Text -> String
T.unpack Text
spelling))
          pathed :: Expression -> Bool
          pathed :: Expression -> Bool
pathed Expression
ExXi = Bool
True
          pathed (ExDispatch Expression
inner Attribute
_) = Expression -> Bool
pathed Expression
inner
          pathed Expression
_ = Bool
False
          side :: String -> Expression -> Yaml.Parser Expression
          side :: String -> Expression -> Parser Expression
side String
_ term :: Expression
term@(ExMeta Text
_) = Expression -> Parser Expression
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
term
          side String
name Expression
term = case Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
term of
            [] -> Expression -> Parser Expression
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
term
            Text
meta : [Text]
_ -> String -> Parser Expression
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 side '%s' of the 'join' block of λ function '%s' reads the meta '%s' inside a term, while a side is a path from '$' or a meta alone" String
name String
key (Text -> String
T.unpack Text
meta))
          fallback :: Text -> Yaml.Parser Function
          fallback :: Text -> Parser Function
fallback Text
spelling = case String -> Either String Binding
parseBinding (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"λ ⤍ %s" (Text -> String
T.unpack Text
spelling)) of
            Right (BiLambda func :: Function
func@(Function Text
_)) -> Function -> Parser Function
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Function
func
            Either String Binding
_ -> String -> Parser Function
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 'otherwise' of the 'join' block of λ function '%s' is '%s', while it must name a λ function, such as 'L_join'" String
key (Text -> String
T.unpack Text
spelling))
      reductions :: Text -> (Text -> Yaml.Parser Meta) -> (Meta -> Meta -> Line) -> Object -> Key -> Yaml.Parser [Either (Meta, Expression) Line]
      reductions :: Text
-> (Text -> Parser Meta)
-> (Meta -> Meta -> Line)
-> Object
-> Key
-> Parser [Either (Meta, Expression) Line]
reductions Text
key Text -> Parser Meta
spelled Meta -> Meta -> Line
kind Object
entry Key
block = do
        Map Text Text
mapping <- Object
entry Object -> Key -> Parser (Maybe (Map Text Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
block Parser (Maybe (Map Text Text))
-> Map Text Text -> Parser (Map Text Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= (Map Text Text
forall k a. Map k a
Map.empty :: Map Text Text)
        ((Text, Text) -> Parser (Either (Meta, Expression) Line))
-> [(Text, Text)] -> Parser [Either (Meta, Expression) Line]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Text, Text) -> Parser (Either (Meta, Expression) Line)
reduction (Map Text Text -> [(Text, Text)]
forall a. Map Text a -> [(Text, a)]
numbered Map Text Text
mapping)
        where
          reduction :: (Text, Text) -> Yaml.Parser (Either (Meta, Expression) Line)
          reduction :: (Text, Text) -> Parser (Either (Meta, Expression) Line)
reduction (Text
meta, Text
source) = do
            Meta
named <- Text -> Parser Meta
spelled Text
meta
            case String -> Either String Expression
parseExpression (Text -> String
T.unpack Text
source) of
              Right (ExMeta Text
name) -> Either (Meta, Expression) Line
-> Parser (Either (Meta, Expression) Line)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Line -> Either (Meta, Expression) Line
forall a b. b -> Either a b
Right (Meta -> Meta -> Line
kind Meta
named (Text -> Text -> Meta
Meta Text
source Text
name)))
              Right Expression
term -> (Meta, Expression) -> Either (Meta, Expression) Line
forall a b. a -> Either a b
Left (Meta
named, Expression
term) Either (Meta, Expression) Line
-> Parser () -> Parser (Either (Meta, Expression) Line)
forall a b. a -> Parser b -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> String -> Expression -> Parser ()
forall (m :: * -> *) a.
(MonadFail m, Slots a) =>
String -> String -> a -> m ()
referenceless (Text -> String
T.unpack Text
key) (Text -> String
T.unpack Text
meta) Expression
term
              Left String
failure -> String -> Parser (Either (Meta, Expression) Line)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
failure Parser (Either (Meta, Expression) Line)
-> JSONPathElement -> Parser (Either (Meta, Expression) Line)
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key (Text -> Key
Key.fromText Text
meta) Parser (Either (Meta, Expression) Line)
-> JSONPathElement -> Parser (Either (Meta, Expression) Line)
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
block
      expressionMeta :: Text -> Yaml.Parser Meta
      expressionMeta :: Text -> Parser Meta
expressionMeta Text
meta = case String -> Either String Expression
parseExpression (Text -> String
T.unpack Text
meta) of
        Right (ExMeta Text
name) -> Meta -> Parser Meta
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Meta
Meta Text
meta Text
name)
        Either String Expression
_ -> String -> Parser Meta
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 operand '%s' is not an expression meta, such as '𝑛1'" (Text -> String
T.unpack Text
meta))
      bytesMeta :: Text -> Yaml.Parser Meta
      bytesMeta :: Text -> Parser Meta
bytesMeta Text
meta = case String -> Either String Bytes
parseBytes (Text -> String
T.unpack Text
meta) of
        Right (BtMeta Text
name) -> Meta -> Parser Meta
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Meta
Meta Text
meta Text
name)
        Either String Bytes
_ -> String -> Parser Meta
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 operand '%s' is not a bytes meta, such as '𝛿1'" (Text -> String
T.unpack Text
meta))
      written :: String -> Object -> Yaml.Parser [Line]
      written :: String -> Object -> Parser [Line]
written String
key Object
entry = [[Line]] -> [Line]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Line]] -> [Line]) -> Parser [[Line]] -> Parser [Line]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parser [Line]] -> Parser [[Line]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [(Meta -> Meta -> Line) -> Object -> Key -> Parser [Line]
links Meta -> Meta -> Line
Evaluated Object
entry Key
"evaluate", (Meta -> Meta -> Line) -> Object -> Key -> Parser [Line]
links Meta -> Meta -> Line
Deferred Object
entry Key
"defer", (Meta -> Meta -> Line) -> Object -> Key -> Parser [Line]
links Meta -> Meta -> Line
Stayed Object
entry Key
"stay", String -> Object -> Parser [Line]
rewrites String
key Object
entry, (Meta -> Meta -> Line) -> Object -> Key -> Parser [Line]
links Meta -> Meta -> Line
Symbolized Object
entry Key
"symbolize", String -> Object -> Parser [Line]
casts String
key Object
entry]
      links :: (Meta -> Meta -> Line) -> Object -> Key -> Yaml.Parser [Line]
      links :: (Meta -> Meta -> Line) -> Object -> Key -> Parser [Line]
links Meta -> Meta -> Line
kind Object
entry Key
name = do
        Map Text Text
mapping <- Object
entry Object -> Key -> Parser (Maybe (Map Text Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
name Parser (Maybe (Map Text Text))
-> Map Text Text -> Parser (Map Text Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= (Map Text Text
forall k a. Map k a
Map.empty :: Map Text Text)
        ((Text, Text) -> Parser Line) -> [(Text, Text)] -> Parser [Line]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Text
meta, Text
source) -> Meta -> Meta -> Line
kind (Meta -> Meta -> Line) -> Parser Meta -> Parser (Meta -> Line)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Meta
expressionMeta Text
meta Parser (Meta -> Line) -> Parser Meta -> Parser Line
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Meta
expressionMeta Text
source) (Map Text Text -> [(Text, Text)]
forall a. Map Text a -> [(Text, a)]
numbered Map Text Text
mapping)
      casts :: String -> Object -> Yaml.Parser [Line]
      casts :: String -> Object -> Parser [Line]
casts String
key Object
entry = do
        Map Text Text
mapping <- Object
entry Object -> Key -> Parser (Maybe (Map Text Text))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"cast" Parser (Maybe (Map Text Text))
-> Map Text Text -> Parser (Map Text Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= (Map Text Text
forall k a. Map k a
Map.empty :: Map Text Text)
        case Map Text Text -> [(Text, Text)]
forall a. Map Text a -> [(Text, a)]
numbered Map Text Text
mapping of
          [] -> [Line] -> Parser [Line]
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          [(Text
one, Text
first), (Text
two, Text
second)] -> (Line -> [Line] -> [Line]
forall a. a -> [a] -> [a]
: []) (Line -> [Line]) -> Parser Line -> Parser [Line]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Meta -> Meta -> Meta -> Meta -> Line
Cast (Meta -> Meta -> Meta -> Meta -> Line)
-> Parser Meta -> Parser (Meta -> Meta -> Meta -> Line)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Meta
expressionMeta Text
one Parser (Meta -> Meta -> Meta -> Line)
-> Parser Meta -> Parser (Meta -> Meta -> Line)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Meta
expressionMeta Text
first Parser (Meta -> Meta -> Line)
-> Parser Meta -> Parser (Meta -> Line)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Meta
expressionMeta Text
two Parser (Meta -> Line) -> Parser Meta -> Parser Line
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Meta
expressionMeta Text
second)
          [(Text, Text)]
pairs ->
            String -> Parser [Line]
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
              ( String -> String -> Int -> String -> String
forall r. PrintfType r => String -> r
printf
                  String
"The 'cast' block of λ function '%s' holds %d %s, while it casts one pair and takes exactly two"
                  String
key
                  ([(Text, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
pairs)
                  (if [(Text, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Text, Text)]
pairs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"line" else String
"lines" :: String)
              )
      rewrites :: String -> Object -> Yaml.Parser [Line]
      rewrites :: String -> Object -> Parser [Line]
rewrites String
key Object
entry = do
        Map Text Object
mapping <- Object
entry Object -> Key -> Parser (Maybe (Map Text Object))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"rewrite" Parser (Maybe (Map Text Object))
-> Map Text Object -> Parser (Map Text Object)
forall a. Parser (Maybe a) -> a -> Parser a
.!= (Map Text Object
forall k a. Map k a
Map.empty :: Map Text Object)
        ((Text, Object) -> Parser Line)
-> [(Text, Object)] -> Parser [Line]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Text, Object) -> Parser Line
line (Map Text Object -> [(Text, Object)]
forall a. Map Text a -> [(Text, a)]
numbered Map Text Object
mapping)
        where
          line :: (Text, Object) -> Yaml.Parser Line
          line :: (Text, Object) -> Parser Line
line (Text
meta, Object
body) = do
            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
"of", Text
"rules"]) ((Key -> Text) -> [Key] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Text
Key.toText (Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
body)) of
              [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Text
name : [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 key '%s' of the line '%s' of the 'rewrite' block of λ function '%s' is none of its keys: of, rules" (Text -> String
T.unpack Text
name) (Text -> String
T.unpack Text
meta) String
key)
            Meta -> Meta -> [Rule] -> Line
Rewritten (Meta -> Meta -> [Rule] -> Line)
-> Parser Meta -> Parser (Meta -> [Rule] -> Line)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Meta
expressionMeta Text
meta Parser (Meta -> [Rule] -> Line)
-> Parser Meta -> Parser ([Rule] -> Line)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Key -> Parser Text
forall value. FromJSON value => Key -> Parser value
required Key
"of" Parser Text -> (Text -> Parser Meta) -> Parser Meta
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Parser Meta
expressionMeta) Parser ([Rule] -> Line) -> Parser [Rule] -> Parser Line
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Key -> Parser [Rule]
forall value. FromJSON value => Key -> Parser value
required Key
"rules" Parser [Rule] -> ([Rule] -> Parser [Rule]) -> Parser [Rule]
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rule -> Parser Rule) -> [Rule] -> Parser [Rule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Rule -> Parser Rule
symbolless)
            where
              required :: FromJSON value => Key -> Yaml.Parser value
              required :: forall value. FromJSON value => Key -> Parser value
required Key
name = Object
body Object -> Key -> Parser (Maybe value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
name Parser (Maybe value)
-> (Maybe value -> Parser value) -> Parser value
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser value
-> (value -> Parser value) -> Maybe value -> Parser value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser value
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 line '%s' of the 'rewrite' block of λ function '%s' has no '%s' key" (Text -> String
T.unpack Text
meta) String
key (Key -> String
Key.toString Key
name))) value -> Parser value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          symbolless :: Y.Rule -> Yaml.Parser Y.Rule
          symbolless :: Rule -> Parser Rule
symbolless Rule
rule = case Expression -> [Int]
symbols Rule
rule.result of
            [] -> Rule -> Parser Rule
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rule
rule
            Int
idx : [Int]
_ -> String -> Parser Rule
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"The rule '%s' of the 'rewrite' block of λ function '%s' writes the symbol '𝜎%d' into its result, while only a firing mints a symbol" Rule
rule.name String
key Int
idx)
      ordered :: String -> [Text] -> [Line] -> Yaml.Parser [Line]
      ordered :: String -> [Text] -> [Line] -> Parser [Line]
ordered String
key [Text]
reduced [Line]
waiting = (Meta -> Parser ()) -> [Meta] -> Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Meta -> Parser ()
bound ((Line -> [Meta]) -> [Line] -> [Meta]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Line -> [Meta]
sources [Line]
waiting) Parser () -> Parser [Line] -> Parser [Line]
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Text] -> [Line] -> Parser [Line]
go [Text]
reduced [Line]
waiting
        where
          bound :: Meta -> Yaml.Parser ()
          bound :: Meta -> Parser ()
bound Meta
meta
            | Meta
meta._name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
reduced [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Meta -> Text) -> [Meta] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Meta -> Text
_name ((Line -> [Meta]) -> [Line] -> [Meta]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Line -> [Meta]
bindings [Line]
waiting) = () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            | Bool
otherwise =
                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 operand '%s' of λ function '%s' names no meta bound by 'morph' or by any line"
                      (Text -> String
T.unpack Meta
meta._spelling)
                      String
key
                  )
          go :: [Text] -> [Line] -> Yaml.Parser [Line]
          go :: [Text] -> [Line] -> Parser [Line]
go [Text]
_ [] = [Line] -> Parser [Line]
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          go [Text]
known pending :: [Line]
pending@(Line
first : [Line]
_) = case (Line -> Bool) -> [Line] -> ([Line], [Line])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Meta -> Bool) -> [Meta] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
known) (Text -> Bool) -> (Meta -> Text) -> Meta -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> Text
_name) ([Meta] -> Bool) -> (Line -> [Meta]) -> Line -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> [Meta]
sources) [Line]
pending of
            ([Line]
before, Line
line : [Line]
after) -> (Line
line Line -> [Line] -> [Line]
forall a. a -> [a] -> [a]
:) ([Line] -> [Line]) -> Parser [Line] -> Parser [Line]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> [Line] -> Parser [Line]
go ((Meta -> Text) -> [Meta] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Meta -> Text
_name (Line -> [Meta]
bindings Line
line) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
known) ([Line]
before [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++ [Line]
after)
            ([Line]
_, []) ->
              String -> Parser [Line]
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 line binding '%s' of λ function '%s' reads the meta it binds, directly or through other lines"
                    (Text -> String
T.unpack ([Text] -> Meta -> Meta
goCircle [] (Line -> Meta
binding Line
first))._spelling)
                    String
key
                )
            where
              goCircle :: [Text] -> Meta -> Meta
              goCircle :: [Text] -> Meta -> Meta
goCircle [Text]
seen Meta
meta
                | Meta
meta._name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
seen = Meta
meta
                | Bool
otherwise = [Text] -> Meta -> Meta
goCircle (Meta
meta._name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
seen) (Meta -> Maybe Meta -> Meta
forall a. a -> Maybe a -> a
fromMaybe Meta
meta ([Meta] -> Maybe Meta
forall a. [a] -> Maybe a
listToMaybe (Meta -> [Meta]
feeding Meta
meta)))
              feeding :: Meta -> [Meta]
              feeding :: Meta -> [Meta]
feeding Meta
meta = [Meta
source | Line
line <- [Line]
pending, Meta
meta._name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Meta -> Text) -> [Meta] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Meta -> Text
_name (Line -> [Meta]
bindings Line
line), Meta
source <- Line -> [Meta]
sources Line
line, Meta
source._name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
known]
          sources :: Line -> [Meta]
          sources :: Line -> [Meta]
sources (Dataized Meta
_ Meta
meta) = [Meta
meta]
          sources (Morphed Meta
_ Meta
meta) = [Meta
meta]
          sources (Undressed Meta
_ Meta
meta) = [Meta
meta]
          sources (Evaluated Meta
_ Meta
meta) = [Meta
meta]
          sources (Deferred Meta
_ Meta
meta) = [Meta
meta]
          sources (Stayed Meta
_ Meta
meta) = [Meta
meta]
          sources (Rewritten Meta
_ Meta
meta [Rule]
_) = [Meta
meta]
          sources (Symbolized Meta
_ Meta
meta) = [Meta
meta]
          sources (Cast Meta
_ Meta
first Meta
_ Meta
second) = [Meta
first, Meta
second]
      binding :: Line -> Meta
      binding :: Line -> Meta
binding (Dataized Meta
meta Meta
_) = Meta
meta
      binding (Morphed Meta
meta Meta
_) = Meta
meta
      binding (Undressed Meta
meta Meta
_) = Meta
meta
      binding (Evaluated Meta
meta Meta
_) = Meta
meta
      binding (Deferred Meta
meta Meta
_) = Meta
meta
      binding (Stayed Meta
meta Meta
_) = Meta
meta
      binding (Rewritten Meta
meta Meta
_ [Rule]
_) = Meta
meta
      binding (Symbolized Meta
meta Meta
_) = Meta
meta
      binding (Cast Meta
meta Meta
_ Meta
_ Meta
_) = Meta
meta
      bindings :: Line -> [Meta]
      bindings :: Line -> [Meta]
bindings (Cast Meta
one Meta
_ Meta
two Meta
_) = [Meta
one, Meta
two]
      bindings Line
line = [Line -> Meta
binding Line
line]
      sigmas :: String -> Expression -> Yaml.Parser ()
      sigmas :: String -> Expression -> Parser ()
sigmas String
key Expression
answer = case ([Text
kind | Slot Text
kind Int
_ <- Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
answer, Text
kind Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"S"], Expression -> [Int]
symbols Expression
answer) of
        ([], []) -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (Text
kind : [Text]
_, [Int]
_) -> 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 anonymous meta '!%s' cannot be referenced in the '𝑛' of λ function '%s'" (Text -> String
T.unpack Text
kind) String
key)
        ([Text]
_, Int
idx : [Int]
_) -> String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"The '𝑛' of λ function '%s' writes the numbered symbol '𝜎%d', while only a bare 𝜎 mints a fresh one" String
key Int
idx)
      once :: String -> Lambda -> Yaml.Parser ()
      once :: String -> Lambda -> Parser ()
once String
key Lambda
lambda = case [Text] -> [Meta] -> Maybe Meta
twice [] [Meta]
bound of
        Maybe Meta
Nothing -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Meta
meta -> 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 meta '%s' of λ function '%s' is bound by more than one line, while each meta may be bound once" (Text -> String
T.unpack Meta
meta._spelling) String
key)
        where
          bound :: [Meta]
          bound :: [Meta]
bound = ((Meta, Expression) -> Meta) -> [(Meta, Expression)] -> [Meta]
forall a b. (a -> b) -> [a] -> [b]
map (Meta, Expression) -> Meta
forall a b. (a, b) -> a
fst (Lambda
lambda._morphed [(Meta, Expression)]
-> [(Meta, Expression)] -> [(Meta, Expression)]
forall a. [a] -> [a] -> [a]
++ Lambda
lambda._undressed) [Meta] -> [Meta] -> [Meta]
forall a. [a] -> [a] -> [a]
++ (Line -> [Meta]) -> [Line] -> [Meta]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Line -> [Meta]
bindings Lambda
lambda._lines
          twice :: [Text] -> [Meta] -> Maybe Meta
          twice :: [Text] -> [Meta] -> Maybe Meta
twice [Text]
_ [] = Maybe Meta
forall a. Maybe a
Nothing
          twice [Text]
seen (Meta
meta : [Meta]
rest)
            | Meta
meta._name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
seen = Meta -> Maybe Meta
forall a. a -> Maybe a
Just Meta
meta
            | Bool
otherwise = [Text] -> [Meta] -> Maybe Meta
twice (Meta
meta._name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
seen) [Meta]
rest
      metaless :: String -> String -> String -> (Meta, Expression) -> Yaml.Parser ()
      metaless :: String -> String -> String -> (Meta, Expression) -> Parser ()
metaless String
key String
block String
reducible (Meta
meta, Expression
term) = case Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
term of
        [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Text
name : [Text]
_ ->
          String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
            ( String -> String -> String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
                String
"The operand '%s' of '%s' of λ function '%s' reads the meta '%s', while only %s can be reduced there"
                (Text -> String
T.unpack Meta
meta._spelling)
                String
block
                String
key
                (Text -> String
T.unpack Text
name)
                String
reducible
            )
      answered :: String -> Lambda -> Yaml.Parser ()
      answered :: String -> Lambda -> Parser ()
answered String
key Lambda
lambda = case Lambda
lambda._ending of
        Joining Either Meta Expression
_ Expression
left Expression
right Maybe Function
_ -> String -> Expression -> Parser ()
sided String
"left" Expression
left Parser () -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Expression -> Parser ()
sided String
"right" Expression
right
        Answering Expression
term -> 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
"S" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
known)) (Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
term) of
          [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Text
name : [Text]
_ -> 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 '𝑛' of λ function '%s' reads the meta '%s' that no block binds" String
key (Text -> String
T.unpack Text
name))
        where
          known :: [Text]
          known :: [Text]
known = ((Meta, Expression) -> Text) -> [(Meta, Expression)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Meta -> Text
_name (Meta -> Text)
-> ((Meta, Expression) -> Meta) -> (Meta, Expression) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Meta, Expression) -> Meta
forall a b. (a, b) -> a
fst) Lambda
lambda._dataized [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
reduced
          reduced :: [Text]
          reduced :: [Text]
reduced = ((Meta, Expression) -> Text) -> [(Meta, Expression)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Meta -> Text
_name (Meta -> Text)
-> ((Meta, Expression) -> Meta) -> (Meta, Expression) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Meta, Expression) -> Meta
forall a b. (a, b) -> a
fst) (Lambda
lambda._morphed [(Meta, Expression)]
-> [(Meta, Expression)] -> [(Meta, Expression)]
forall a. [a] -> [a] -> [a]
++ Lambda
lambda._undressed) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Meta -> Text) -> [Meta] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Meta -> Text
_name ((Line -> [Meta]) -> [Line] -> [Meta]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Line -> [Meta]
bindings Lambda
lambda._lines)
          sided :: String -> Expression -> Yaml.Parser ()
          sided :: String -> Expression -> Parser ()
sided String
name Expression
side = 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]
reduced) (Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
side) of
            [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Text
meta : [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 side '%s' of the 'join' block of λ function '%s' reads the meta '%s' that none of 'morph', 'undress', 'evaluate', 'stay', 'rewrite', 'symbolize', 'cast' and 'defer' binds" String
name String
key (Text -> String
T.unpack Text
meta))
      dataless :: String -> Expression -> Yaml.Parser ()
      dataless :: String -> Expression -> Parser ()
dataless String
key Expression
answer
        | Expression -> Bool
computes Expression
answer = 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 '𝑛' of λ function '%s' reads data, while a symbolic answer may mention nothing but 𝜎" String
key)
        | Bool
otherwise = () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

numbered :: Map Text a -> [(Text, a)]
numbered :: forall a. Map Text a -> [(Text, a)]
numbered = ((Text, a) -> (Text, Integer)) -> [(Text, a)] -> [(Text, a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Text -> (Text, Integer)
order (Text -> (Text, Integer))
-> ((Text, a) -> Text) -> (Text, a) -> (Text, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, a) -> Text
forall a b. (a, b) -> a
fst) ([(Text, a)] -> [(Text, a)])
-> (Map Text a -> [(Text, a)]) -> Map Text a -> [(Text, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text a -> [(Text, a)]
forall k a. Map k a -> [(k, a)]
Map.toList
  where
    order :: Text -> (Text, Integer)
    order :: Text -> (Text, Integer)
order Text
meta = case (Char -> Bool) -> Text -> Text
T.takeWhileEnd Char -> Bool
isDigit Text
meta of
      Text
digits | Text -> Bool
T.null Text
digits -> (Text
meta, Integer
0)
      Text
digits -> ((Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isDigit Text
meta, String -> Integer
forall a. Read a => String -> a
read (Text -> String
T.unpack Text
digits))

computes :: Expression -> Bool
computes :: Expression -> Bool
computes = Expression -> Bool
goExpr
  where
    goExpr :: Expression -> Bool
    goExpr :: Expression -> Bool
goExpr (ExFormation [Binding]
bds) = (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
goBinding [Binding]
bds
    goExpr (ExApplication Expression
expr Argument
arg) = Expression -> Bool
goExpr Expression
expr Bool -> Bool -> Bool
|| Argument -> Bool
goArgument Argument
arg
    goExpr (ExDispatch Expression
expr Attribute
_) = Expression -> Bool
goExpr Expression
expr
    goExpr (ExPhiMeet Maybe String
_ Int
_ Expression
expr) = Expression -> Bool
goExpr Expression
expr
    goExpr (ExPhiAgain Maybe String
_ Int
_ Expression
expr) = Expression -> Bool
goExpr Expression
expr
    goExpr (ExBytes Bytes
bts) = Bytes -> Bool
goBytes Bytes
bts
    goExpr Expression
_ = Bool
False
    goBinding :: Binding -> Bool
    goBinding :: Binding -> Bool
goBinding (BiTau Attribute
_ Expression
expr) = Expression -> Bool
goExpr Expression
expr
    goBinding (BiDelta Bytes
bts) = Bytes -> Bool
goBytes Bytes
bts
    goBinding Binding
_ = Bool
False
    goArgument :: Argument -> Bool
    goArgument :: Argument -> Bool
goArgument (ArTau Attribute
_ Expression
expr) = Expression -> Bool
goExpr Expression
expr
    goArgument (ArAlpha Alpha
_ Expression
expr) = Expression -> Bool
goExpr Expression
expr
    goBytes :: Bytes -> Bool
    goBytes :: Bytes -> Bool
goBytes (BtMeta Text
_) = Bool
True
    goBytes (BtAny Slot
_) = Bool
True
    goBytes Bytes
_ = Bool
False

emptyLambdas :: Lambdas
emptyLambdas :: Lambdas
emptyLambdas = [(Regex, Lambda)] -> Lambdas
Lambdas []

sized :: Lambdas -> Int
sized :: Lambdas -> Int
sized (Lambdas [(Regex, Lambda)]
registered) = [(Regex, Lambda)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Regex, Lambda)]
registered

readLambdas :: FilePath -> IO Lambdas
readLambdas :: String -> IO Lambdas
readLambdas String
path = do
  [Lambda]
entries <- String -> IO (Either ParseException [Lambda])
forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither String
path IO (Either ParseException [Lambda])
-> (Either ParseException [Lambda] -> IO [Lambda]) -> IO [Lambda]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ParseException -> IO [Lambda])
-> ([Lambda] -> IO [Lambda])
-> Either ParseException [Lambda]
-> IO [Lambda]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> IO [Lambda]
broken [Lambda] -> IO [Lambda]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (Lambda -> IO ()) -> [Lambda] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Lambda] -> Lambda -> IO ()
unique [Lambda]
entries) [Lambda]
entries
  [(Regex, Lambda)]
registered <- (Lambda -> IO (Regex, Lambda)) -> [Lambda] -> IO [(Regex, Lambda)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Lambda -> IO (Regex, Lambda)
keyed [Lambda]
entries
  String -> [(Regex, Lambda)] -> IO ()
overlaps String
path [(Regex, Lambda)]
registered
  (Lambda -> IO ()) -> [Lambda] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([(Regex, Lambda)] -> Lambda -> IO ()
answering [(Regex, Lambda)]
registered) [Lambda]
entries
  String -> IO ()
logDebug (String -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
"Loaded %d λ function(s) from '%s'" ([Lambda] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Lambda]
entries) String
path)
  Lambdas -> IO Lambdas
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Regex, Lambda)] -> Lambdas
Lambdas [(Regex, Lambda)]
registered)
  where
    broken :: Yaml.ParseException -> IO [Lambda]
    broken :: ParseException -> IO [Lambda]
broken ParseException
failure = LambdaException -> IO [Lambda]
forall e a. Exception e => e -> IO a
throwIO (String -> String -> LambdaException
BrokenLambdas String
path (String -> String
Y.shiftYamlError (ParseException -> String
Yaml.prettyPrintParseException ParseException
failure)))
    unique :: [Lambda] -> Lambda -> IO ()
    unique :: [Lambda] -> Lambda -> IO ()
unique [Lambda]
entries Lambda
entry
      | [Lambda] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Lambda -> Bool) -> [Lambda] -> [Lambda]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Lambda
entry._key) (Text -> Bool) -> (Lambda -> Text) -> Lambda -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (._key)) [Lambda]
entries) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = LambdaException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> String -> LambdaException
BrokenLambdas String
path (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"the key '%s' is used by more than one entry" (Text -> String
T.unpack Lambda
entry._key)))
    keyed :: Lambda -> IO (Regex, Lambda)
    keyed :: Lambda -> IO (Regex, Lambda)
keyed Lambda
entry = do
      Either (Int, String) Regex
compiled <- CompOption
-> ExecOption -> ByteString -> IO (Either (Int, String) Regex)
compile CompOption
compUTF8 ExecOption
execBlank (Text -> ByteString
encodeUtf8 (Text
"^(?:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Lambda
entry._key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")$"))
      ((Int, String) -> IO (Regex, Lambda))
-> (Regex -> IO (Regex, Lambda))
-> Either (Int, String) Regex
-> IO (Regex, Lambda)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> (Int, String) -> IO (Regex, Lambda)
forall a b. Text -> (a, String) -> IO b
unreadable Lambda
entry._key) (\Regex
key -> (Regex, Lambda) -> IO (Regex, Lambda)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Regex
key, Lambda
entry)) Either (Int, String) Regex
compiled
    unreadable :: Text -> (a, String) -> IO b
    unreadable :: forall a b. Text -> (a, String) -> IO b
unreadable Text
key (a
_, String
failure) =
      LambdaException -> IO b
forall e a. Exception e => e -> IO a
throwIO (String -> String -> LambdaException
BrokenLambdas String
path (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"the key '%s' is not a regular expression: %s" (Text -> String
T.unpack Text
key) String
failure))
    answering :: [(Regex, Lambda)] -> Lambda -> IO ()
    answering :: [(Regex, Lambda)] -> Lambda -> IO ()
answering [(Regex, Lambda)]
registered Lambda
entry = case [(Text
name, Lambda
other) | Text
name <- Lambda
entry._terminators, Just Lambda
other <- [Lambdas -> Text -> Maybe Lambda
matched ([(Regex, Lambda)] -> Lambdas
Lambdas [(Regex, Lambda)]
registered) Text
name]] of
      [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (Text
name, Lambda
other) : [(Text, Lambda)]
_ -> LambdaException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> String -> LambdaException
BrokenLambdas String
path (String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"the terminator '%s' of the key '%s' is answered by the key '%s'" (Text -> String
T.unpack Text
name) (Text -> String
T.unpack Lambda
entry._key) (Text -> String
T.unpack Lambda
other._key)))
    overlaps :: FilePath -> [(Regex, Lambda)] -> IO ()
    overlaps :: String -> [(Regex, Lambda)] -> IO ()
overlaps String
_ [(Regex, Lambda)
_] = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    overlaps String
file [(Regex, Lambda)]
registered = ((Regex, Lambda) -> IO (Lambda, Language))
-> [(Regex, Lambda)] -> IO [(Lambda, Language)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Lambda -> IO (Lambda, Language)
spoken (Lambda -> IO (Lambda, Language))
-> ((Regex, Lambda) -> Lambda)
-> (Regex, Lambda)
-> IO (Lambda, Language)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Regex, Lambda) -> Lambda
forall a b. (a, b) -> b
snd) [(Regex, Lambda)]
registered IO [(Lambda, Language)] -> ([(Lambda, Language)] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Lambda, Language)] -> IO ()
check
      where
        spoken :: Lambda -> IO (Lambda, Language)
        spoken :: Lambda -> IO (Lambda, Language)
spoken Lambda
entry =
          (String -> IO (Lambda, Language))
-> (Language -> IO (Lambda, Language))
-> Either String Language
-> IO (Lambda, Language)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (LambdaException -> IO (Lambda, Language)
forall e a. Exception e => e -> IO a
throwIO (LambdaException -> IO (Lambda, Language))
-> (String -> LambdaException) -> String -> IO (Lambda, Language)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> LambdaException
BrokenLambdas String
file (String -> LambdaException)
-> (String -> String) -> String -> LambdaException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"the key '%s' cannot be compared with the other keys: %s" (Text -> String
T.unpack Lambda
entry._key))
            ((Lambda, Language) -> IO (Lambda, Language)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Lambda, Language) -> IO (Lambda, Language))
-> (Language -> (Lambda, Language))
-> Language
-> IO (Lambda, Language)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Lambda
entry)
            (Text -> Either String Language
language Lambda
entry._key)
        check :: [(Lambda, Language)] -> IO ()
        check :: [(Lambda, Language)] -> IO ()
check [] = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        check ((Lambda, Language)
first : [(Lambda, Language)]
rest) = ((Lambda, Language) -> IO ()) -> [(Lambda, Language)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Lambda, Language) -> (Lambda, Language) -> IO ()
pair (Lambda, Language)
first) [(Lambda, Language)]
rest IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Lambda, Language)] -> IO ()
check [(Lambda, Language)]
rest
        pair :: (Lambda, Language) -> (Lambda, Language) -> IO ()
        pair :: (Lambda, Language) -> (Lambda, Language) -> IO ()
pair (Lambda
left, Language
one) (Lambda
right, Language
other) =
          IO () -> (Text -> IO ()) -> Maybe Text -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            ( LambdaException -> IO ()
forall e a. Exception e => e -> IO a
throwIO
                (LambdaException -> IO ())
-> (Text -> LambdaException) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> LambdaException
BrokenLambdas String
file
                (String -> LambdaException)
-> (Text -> String) -> Text -> LambdaException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"the keys '%s' and '%s' match some of the same lambda names, such as '%s'" (Text -> String
T.unpack Lambda
left._key) (Text -> String
T.unpack Lambda
right._key)
                (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
            )
            (Language -> Language -> Maybe Text
shared Language
one Language
other)

matched :: Lambdas -> Text -> Maybe Lambda
matched :: Lambdas -> Text -> Maybe Lambda
matched (Lambdas [(Regex, Lambda)]
entries) Text
func = (Regex, Lambda) -> Lambda
forall a b. (a, b) -> b
snd ((Regex, Lambda) -> Lambda)
-> Maybe (Regex, Lambda) -> Maybe Lambda
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Regex, Lambda) -> Bool)
-> [(Regex, Lambda)] -> Maybe (Regex, Lambda)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Regex
key, Lambda
_) -> Regex -> ByteString -> Bool
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
matchTest Regex
key (Text -> ByteString
encodeUtf8 Text
func)) [(Regex, Lambda)]
entries

minted :: Expression -> Int -> ([(Slot, Function)], Int)
minted :: Expression -> Int -> ([(Slot, Function)], Int)
minted Expression
answer Int
spent = ([Slot] -> [Function] -> [(Slot, Function)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Slot]
fresh [Int -> Function
FnSymbol Int
idx | Int
idx <- [Int
spent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 ..]], Int
spent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Slot] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Slot]
fresh)
  where
    fresh :: [Slot]
    fresh :: [Slot]
fresh = [Slot
slot | slot :: Slot
slot@(Slot Text
kind Int
_) <- Expression -> [Slot]
forall a. Slots a => a -> [Slot]
slots Expression
answer, Text
kind Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"S"]

thrown :: [Text] -> Expression -> Bool
thrown :: [Text] -> Expression -> Bool
thrown [Text]
names (ExApplication Expression
expr Argument
_) = [Text] -> Expression -> Bool
thrown [Text]
names Expression
expr
thrown [Text]
names (ExFormation [Binding]
bds) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Text
name Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
names | BiLambda (Function Text
name) <- [Binding]
bds]
thrown [Text]
_ Expression
_ = Bool
False

taken :: Expression -> Int
taken :: Expression -> Int
taken Expression
program = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Expression -> [Int]
symbols Expression
program)

stayed :: Expression -> Expression
stayed :: Expression -> Expression
stayed = Expression -> Expression
goExpr
  where
    goExpr :: Expression -> Expression
    goExpr :: Expression -> Expression
goExpr (ExFormation [Binding]
bds) = [Binding] -> Expression
ExFormation ((Binding -> Binding) -> [Binding] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Binding
goBinding [Binding]
bds)
    goExpr (ExApplication Expression
expr Argument
arg) = case (Expression -> Expression
goExpr Expression
expr, Argument
arg) of
      (Expression
target, ArTau Attribute
AtRho Expression
_) | Expression -> Bool
dispatched Expression
target -> Expression
target
      (Expression
target, Argument
_) -> Expression -> Argument -> Expression
ExApplication Expression
target (Argument -> Argument
goArgument Argument
arg)
    goExpr (ExDispatch Expression
expr Attribute
attr) = Expression -> Attribute -> Expression
ExDispatch (Expression -> Expression
goExpr Expression
expr) Attribute
attr
    goExpr (ExPhiMeet Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiMeet Maybe String
prefix Int
idx (Expression -> Expression
goExpr Expression
expr)
    goExpr (ExPhiAgain Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiAgain Maybe String
prefix Int
idx (Expression -> Expression
goExpr Expression
expr)
    goExpr Expression
expr = Expression
expr
    goBinding :: Binding -> Binding
    goBinding :: Binding -> Binding
goBinding (BiTau Attribute
attr Expression
expr) = Attribute -> Expression -> Binding
BiTau Attribute
attr (Expression -> Expression
goExpr Expression
expr)
    goBinding Binding
bd = Binding
bd
    goArgument :: Argument -> Argument
    goArgument :: Argument -> Argument
goArgument (ArTau Attribute
attr Expression
expr) = Attribute -> Expression -> Argument
ArTau Attribute
attr (Expression -> Expression
goExpr Expression
expr)
    goArgument (ArAlpha Alpha
alpha Expression
expr) = Alpha -> Expression -> Argument
ArAlpha Alpha
alpha (Expression -> Expression
goExpr Expression
expr)
    dispatched :: Expression -> Bool
    dispatched :: Expression -> Bool
dispatched (ExDispatch Expression
_ Attribute
_) = Bool
True
    dispatched (ExApplication Expression
expr Argument
_) = Expression -> Bool
dispatched Expression
expr
    dispatched Expression
_ = Bool
False

cast :: Expression -> Expression -> Maybe Expression
cast :: Expression -> Expression -> Maybe Expression
cast bare :: Expression
bare@(ExFormation [BiLambda (FnSymbol Int
_)]) Expression
shape
  | Expression -> Bool
decorating Expression
shape = Expression -> Maybe Expression
forall a. a -> Maybe a
Just (Expression -> Expression
goExpr Expression
shape)
  where
    goExpr :: Expression -> Expression
    goExpr :: Expression -> Expression
goExpr body :: Expression
body@(ExFormation [Binding]
bds) | Expression -> Bool
decorating Expression
body = [Binding] -> Expression
ExFormation ((Binding -> Binding) -> [Binding] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Binding
placed [Binding]
bds)
    goExpr Expression
_ = Expression
bare
    placed :: Binding -> Binding
    placed :: Binding -> Binding
placed (BiTau Attribute
AtPhi Expression
body) = Attribute -> Expression -> Binding
BiTau Attribute
AtPhi (Expression -> Expression
goExpr Expression
body)
    placed Binding
bd = Binding
bd
    decorating :: Expression -> Bool
    decorating :: Expression -> Bool
decorating (ExFormation [Binding]
bds) = Attribute
AtPhi Attribute -> [Attribute] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Attribute
attr | BiTau Attribute
attr Expression
_ <- [Binding]
bds]
    decorating Expression
_ = Bool
False
cast Expression
_ Expression
_ = Maybe Expression
forall a. Maybe a
Nothing

rewritten :: RuleContext -> [Y.Rule] -> Expression -> IO Expression
rewritten :: RuleContext -> [Rule] -> Expression -> IO Expression
rewritten RuleContext
ctx [Rule]
rules = Expression -> IO Expression
goExpr
  where
    goExpr :: Expression -> IO Expression
    goExpr :: Expression -> IO Expression
goExpr Expression
expr = Expression -> Expression -> Expression
kept Expression
expr (Expression -> Expression) -> IO Expression -> IO Expression
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Expression -> [Rule] -> IO Expression
goRules Expression
expr [Rule]
rules
    kept :: Expression -> Expression -> Expression
    kept :: Expression -> Expression -> Expression
kept Expression
expr Expression
made
      | Expression
made Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
expr = Expression
expr
      | Bool
otherwise = Expression
made
    goRules :: Expression -> [Y.Rule] -> IO Expression
    goRules :: Expression -> [Rule] -> IO Expression
goRules Expression
expr [] = Expression -> IO Expression
goInside Expression
expr
    goRules Expression
expr (Rule
rule : [Rule]
rest) = do
      [Subst]
substs <- [Subst] -> Expression -> Rule -> RuleContext -> IO [Subst]
matchExpressionWithRule' [Subst
substEmpty] Expression
expr Rule
rule RuleContext
ctx
      case [Subst]
substs of
        Subst
subst : [Subst]
_ -> Expression -> Subst -> IO Expression
buildExpressionThrows Rule
rule.result Subst
subst
        [] -> Expression -> [Rule] -> IO Expression
goRules Expression
expr [Rule]
rest
    goInside :: Expression -> IO Expression
    goInside :: Expression -> IO Expression
goInside (ExFormation [Binding]
bds) = [Binding] -> Expression
ExFormation ([Binding] -> Expression) -> IO [Binding] -> IO Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Binding -> IO Binding) -> [Binding] -> IO [Binding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> IO Binding
goBinding [Binding]
bds
    goInside (ExApplication Expression
expr Argument
arg) = Expression -> Argument -> Expression
ExApplication (Expression -> Argument -> Expression)
-> IO Expression -> IO (Argument -> Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> IO Expression
goExpr Expression
expr IO (Argument -> Expression) -> IO Argument -> IO Expression
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Argument -> IO Argument
goArgument Argument
arg
    goInside (ExDispatch Expression
expr Attribute
attr) = (Expression -> Attribute -> Expression
`ExDispatch` Attribute
attr) (Expression -> Expression) -> IO Expression -> IO Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> IO Expression
goExpr Expression
expr
    goInside (ExPhiMeet Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiMeet Maybe String
prefix Int
idx (Expression -> Expression) -> IO Expression -> IO Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> IO Expression
goExpr Expression
expr
    goInside (ExPhiAgain Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiAgain Maybe String
prefix Int
idx (Expression -> Expression) -> IO Expression -> IO Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> IO Expression
goExpr Expression
expr
    goInside Expression
expr = Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr
    goBinding :: Binding -> IO Binding
    goBinding :: Binding -> IO Binding
goBinding (BiTau Attribute
attr Expression
expr) = Attribute -> Expression -> Binding
BiTau Attribute
attr (Expression -> Binding) -> IO Expression -> IO Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> IO Expression
goExpr Expression
expr
    goBinding Binding
bd = Binding -> IO Binding
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
bd
    goArgument :: Argument -> IO Argument
    goArgument :: Argument -> IO Argument
goArgument (ArTau Attribute
attr Expression
expr) = Attribute -> Expression -> Argument
ArTau Attribute
attr (Expression -> Argument) -> IO Expression -> IO Argument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> IO Expression
goExpr Expression
expr
    goArgument (ArAlpha Alpha
alpha Expression
expr) = Alpha -> Expression -> Argument
ArAlpha Alpha
alpha (Expression -> Argument) -> IO Expression -> IO Argument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> IO Expression
goExpr Expression
expr

type Minting = (Int, [(Int, Bytes)])

symbolized :: Expression -> Int -> (Expression, [(Int, Bytes)], Int)
symbolized :: Expression -> Int -> (Expression, [(Int, Bytes)], Int)
symbolized Expression
term Int
spent = case State Minting Expression -> Minting -> (Expression, Minting)
forall s a. State s a -> s -> (a, s)
runState (Expression -> State Minting Expression
goExpr Expression
term) (Int
spent, []) of
  (Expression
masked, (Int
spent', [(Int, Bytes)]
known)) -> (Expression
masked, [(Int, Bytes)] -> [(Int, Bytes)]
forall a. [a] -> [a]
reverse [(Int, Bytes)]
known, Int
spent')
  where
    goExpr :: Expression -> State Minting Expression
    goExpr :: Expression -> State Minting Expression
goExpr (ExFormation [Binding]
bds) = [Binding] -> Expression
ExFormation ([Binding] -> Expression)
-> StateT Minting Identity [Binding] -> State Minting Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Binding -> StateT Minting Identity Binding)
-> [Binding] -> StateT Minting Identity [Binding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool -> Binding -> StateT Minting Identity Binding
goBinding (Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
AtLambda Maybe Attribute -> [Maybe Attribute] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Binding -> Maybe Attribute) -> [Binding] -> [Maybe Attribute]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Maybe Attribute
attributeFromBinding [Binding]
bds)) [Binding]
bds
    goExpr (ExApplication Expression
expr Argument
arg) = Expression -> Argument -> Expression
ExApplication (Expression -> Argument -> Expression)
-> State Minting Expression
-> StateT Minting Identity (Argument -> Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Minting Expression
goExpr Expression
expr StateT Minting Identity (Argument -> Expression)
-> StateT Minting Identity Argument -> State Minting Expression
forall a b.
StateT Minting Identity (a -> b)
-> StateT Minting Identity a -> StateT Minting Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Argument -> StateT Minting Identity Argument
goArgument Argument
arg
    goExpr (ExDispatch Expression
expr Attribute
attr) = (Expression -> Attribute -> Expression
`ExDispatch` Attribute
attr) (Expression -> Expression)
-> State Minting Expression -> State Minting Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Minting Expression
goExpr Expression
expr
    goExpr (ExPhiMeet Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiMeet Maybe String
prefix Int
idx (Expression -> Expression)
-> State Minting Expression -> State Minting Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Minting Expression
goExpr Expression
expr
    goExpr (ExPhiAgain Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiAgain Maybe String
prefix Int
idx (Expression -> Expression)
-> State Minting Expression -> State Minting Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Minting Expression
goExpr Expression
expr
    goExpr Expression
expr = Expression -> State Minting Expression
forall a. a -> StateT Minting Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr
    goBinding :: Bool -> Binding -> State Minting Binding
    goBinding :: Bool -> Binding -> StateT Minting Identity Binding
goBinding Bool
_ (BiDelta Bytes
bts) = (Minting -> (Binding, Minting)) -> StateT Minting Identity Binding
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (\(Int
count, [(Int, Bytes)]
known) -> (Function -> Binding
BiLambda (Int -> Function
FnSymbol (Int -> Int
forall a. Enum a => a -> a
succ Int
count)), (Int -> Int
forall a. Enum a => a -> a
succ Int
count, (Int -> Int
forall a. Enum a => a -> a
succ Int
count, Bytes
bts) (Int, Bytes) -> [(Int, Bytes)] -> [(Int, Bytes)]
forall a. a -> [a] -> [a]
: [(Int, Bytes)]
known)))
    goBinding Bool
atom (BiTau Attribute
attr Expression
expr) | Bool
atom Bool -> Bool -> Bool
|| Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
AtPhi = Attribute -> Expression -> Binding
BiTau Attribute
attr (Expression -> Binding)
-> State Minting Expression -> StateT Minting Identity Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Minting Expression
goExpr Expression
expr
    goBinding Bool
_ Binding
bd = Binding -> StateT Minting Identity Binding
forall a. a -> StateT Minting Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
bd
    goArgument :: Argument -> State Minting Argument
    goArgument :: Argument -> StateT Minting Identity Argument
goArgument (ArTau Attribute
attr Expression
expr) = Attribute -> Expression -> Argument
ArTau Attribute
attr (Expression -> Argument)
-> State Minting Expression -> StateT Minting Identity Argument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Minting Expression
goExpr Expression
expr
    goArgument (ArAlpha Alpha
alpha Expression
expr) = Alpha -> Expression -> Argument
ArAlpha Alpha
alpha (Expression -> Argument)
-> State Minting Expression -> StateT Minting Identity Argument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Minting Expression
goExpr Expression
expr