{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}

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

-- The goal of the module is to build phi expression based on
-- pattern expression and set of substitutions by replacing
-- meta variables with appropriate meta values
module Builder
  ( buildExpressions,
    buildExpression,
    buildExpressionThrows,
    buildAttribute,
    buildAttributeThrows,
    buildBinding,
    buildBindingThrows,
    buildBytes,
    buildBytesThrows,
    contextualize,
    BuildException (..),
  )
where

import Ast
import Control.Exception (Exception, throwIO)
import qualified Data.Map.Strict as Map
import Matcher
import Pretty (prettyAttribute, prettyBinding, prettyExpression, prettySubst, prettyBytes)
import Text.Printf (printf)
import Yaml (ExtraArgument (..))

data BuildException
  = CouldNotBuildExpression {BuildException -> Expression
_expr :: Expression, BuildException -> Subst
_subst :: Subst}
  | CouldNotBuildAttribute {BuildException -> Attribute
_attr :: Attribute, _subst :: Subst}
  | CouldNotBuildBinding {BuildException -> Binding
_bd :: Binding, _subst :: Subst}
  | CouldNotBuildBytes {BuildException -> Bytes
_bts :: Bytes, _subst :: Subst}
  deriving (Show BuildException
Typeable BuildException
(Typeable BuildException, Show BuildException) =>
(BuildException -> SomeException)
-> (SomeException -> Maybe BuildException)
-> (BuildException -> String)
-> Exception BuildException
SomeException -> Maybe BuildException
BuildException -> String
BuildException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: BuildException -> SomeException
toException :: BuildException -> SomeException
$cfromException :: SomeException -> Maybe BuildException
fromException :: SomeException -> Maybe BuildException
$cdisplayException :: BuildException -> String
displayException :: BuildException -> String
Exception)

instance Show BuildException where
  show :: BuildException -> String
show CouldNotBuildExpression {Expression
Subst
_expr :: BuildException -> Expression
_subst :: BuildException -> Subst
_expr :: Expression
_subst :: Subst
..} =
    String -> String -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"Couldn't build given expression with provided substitutions\n--Expression: %s\n--Substitutions: %s"
      (Expression -> String
prettyExpression Expression
_expr)
      (Subst -> String
prettySubst Subst
_subst)
  show CouldNotBuildAttribute {Attribute
Subst
_subst :: BuildException -> Subst
_attr :: BuildException -> Attribute
_attr :: Attribute
_subst :: Subst
..} =
    String -> String -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"Couldn't build given attribute with provided substitutions\n--Attribute: %s\n--Substitutions: %s"
      (Attribute -> String
prettyAttribute Attribute
_attr)
      (Subst -> String
prettySubst Subst
_subst)
  show CouldNotBuildBinding {Binding
Subst
_subst :: BuildException -> Subst
_bd :: BuildException -> Binding
_bd :: Binding
_subst :: Subst
..} =
    String -> String -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"Couldn't build given binding with provided substitutions\n--Binding: %s\n--Substitutions: %s"
      (Binding -> String
prettyBinding Binding
_bd)
      (Subst -> String
prettySubst Subst
_subst)
  show CouldNotBuildBytes {Bytes
Subst
_subst :: BuildException -> Subst
_bts :: BuildException -> Bytes
_bts :: Bytes
_subst :: Subst
..} =
    String -> String -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"Couldn't build given bytes with provided substitutions\n--Bytes: %s\n--Substitutions: %s"
      (Bytes -> String
prettyBytes Bytes
_bts)
      (Subst -> String
prettySubst Subst
_subst)

contextualize :: Expression -> Expression -> Program -> Expression
contextualize :: Expression -> Expression -> Program -> Expression
contextualize Expression
ExGlobal Expression
_ (Program Expression
expr) = Expression
expr
contextualize Expression
ExThis Expression
expr Program
_ = Expression
expr
contextualize Expression
ExTermination Expression
_ Program
_ = Expression
ExTermination
contextualize (ExFormation [Binding]
bds) Expression
_ Program
_ = [Binding] -> Expression
ExFormation [Binding]
bds
contextualize (ExDispatch Expression
expr Attribute
attr) Expression
context Program
prog = Expression -> Attribute -> Expression
ExDispatch (Expression -> Expression -> Program -> Expression
contextualize Expression
expr Expression
context Program
prog) Attribute
attr
contextualize (ExApplication Expression
expr (BiTau Attribute
attr Expression
bexpr)) Expression
context Program
prog =
  let expr' :: Expression
expr' = Expression -> Expression -> Program -> Expression
contextualize Expression
expr Expression
context Program
prog
      bexpr' :: Expression
bexpr' = Expression -> Expression -> Program -> Expression
contextualize Expression
bexpr Expression
context Program
prog
   in Expression -> Binding -> Expression
ExApplication Expression
expr' (Attribute -> Expression -> Binding
BiTau Attribute
attr Expression
bexpr')

buildAttribute :: Attribute -> Subst -> Maybe Attribute
buildAttribute :: Attribute -> Subst -> Maybe Attribute
buildAttribute (AtMeta String
meta) (Subst Map String MetaValue
mp) = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
meta Map String MetaValue
mp of
  Just (MvAttribute Attribute
attr) -> Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
attr
  Maybe MetaValue
_ -> Maybe Attribute
forall a. Maybe a
Nothing
buildAttribute Attribute
attr Subst
_ = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
attr

buildBytes :: Bytes -> Subst -> Maybe Bytes
buildBytes :: Bytes -> Subst -> Maybe Bytes
buildBytes (BtMeta String
meta) (Subst Map String MetaValue
mp) = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
meta Map String MetaValue
mp of
  Just (MvBytes Bytes
bytes) -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
bytes
  Maybe MetaValue
_ -> Maybe Bytes
forall a. Maybe a
Nothing
buildBytes Bytes
bts Subst
_ = Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
bts

-- Build binding
-- The function returns [Binding] because the BiMeta is always attached
-- to the list of bindings
buildBinding :: Binding -> Subst -> Maybe [Binding]
buildBinding :: Binding -> Subst -> Maybe [Binding]
buildBinding (BiTau Attribute
attr Expression
expr) Subst
subst = do
  Attribute
attribute <- Attribute -> Subst -> Maybe Attribute
buildAttribute Attribute
attr Subst
subst
  (Expression
expression, Expression
_) <- Expression -> Subst -> Maybe (Expression, Expression)
buildExpression Expression
expr Subst
subst
  [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just [Attribute -> Expression -> Binding
BiTau Attribute
attribute Expression
expression]
buildBinding (BiVoid Attribute
attr) Subst
subst = do
  Attribute
attribute <- Attribute -> Subst -> Maybe Attribute
buildAttribute Attribute
attr Subst
subst
  [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just [Attribute -> Binding
BiVoid Attribute
attribute]
buildBinding (BiMeta String
meta) (Subst Map String MetaValue
mp) = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
meta Map String MetaValue
mp of
  Just (MvBindings [Binding]
bds) -> [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just [Binding]
bds
  Maybe MetaValue
_ -> Maybe [Binding]
forall a. Maybe a
Nothing
buildBinding (BiDelta Bytes
bytes) Subst
subst = do
  Bytes
bts <- Bytes -> Subst -> Maybe Bytes
buildBytes Bytes
bytes Subst
subst
  [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just [Bytes -> Binding
BiDelta Bytes
bts]
buildBinding (BiMetaLambda String
meta) (Subst Map String MetaValue
mp) = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
meta Map String MetaValue
mp of
  Just (MvFunction String
func) -> [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just [String -> Binding
BiLambda String
func]
  Maybe MetaValue
_ -> Maybe [Binding]
forall a. Maybe a
Nothing
buildBinding Binding
binding Subst
_ = [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just [Binding
binding]

-- Build bindings that may contain meta binding (BiMeta)
buildBindings :: [Binding] -> Subst -> Maybe [Binding]
buildBindings :: [Binding] -> Subst -> Maybe [Binding]
buildBindings [] Subst
_ = [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just []
buildBindings (Binding
bd : [Binding]
rest) Subst
subst = do
  [Binding]
first <- Binding -> Subst -> Maybe [Binding]
buildBinding Binding
bd Subst
subst
  [Binding]
bds <- [Binding] -> Subst -> Maybe [Binding]
buildBindings [Binding]
rest Subst
subst
  [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just ([Binding]
first [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ [Binding]
bds)

buildExpressionWithTails :: Expression -> [Tail] -> Subst -> Expression
buildExpressionWithTails :: Expression -> [Tail] -> Subst -> Expression
buildExpressionWithTails Expression
expr [] Subst
_ = Expression
expr
buildExpressionWithTails Expression
expr (Tail
tail : [Tail]
rest) Subst
subst = case Tail
tail of
  TaApplication Binding
taus -> Expression -> [Tail] -> Subst -> Expression
buildExpressionWithTails (Expression -> Binding -> Expression
ExApplication Expression
expr Binding
taus) [Tail]
rest Subst
subst
  TaDispatch Attribute
attr -> Expression -> [Tail] -> Subst -> Expression
buildExpressionWithTails (Expression -> Attribute -> Expression
ExDispatch Expression
expr Attribute
attr) [Tail]
rest Subst
subst

-- Build meta expression with given substitution
-- It returns tuple (X, Y)
-- where X is built expression and Y is context of X
-- If meta expression is built from MvExpression, is has
-- context from original Program. It have default context otherwise
buildExpression :: Expression -> Subst -> Maybe (Expression, Expression)
buildExpression :: Expression -> Subst -> Maybe (Expression, Expression)
buildExpression (ExDispatch Expression
expr Attribute
attr) Subst
subst = do
  (Expression
dispatched, Expression
scope) <- Expression -> Subst -> Maybe (Expression, Expression)
buildExpression Expression
expr Subst
subst
  Attribute
attr <- Attribute -> Subst -> Maybe Attribute
buildAttribute Attribute
attr Subst
subst
  (Expression, Expression) -> Maybe (Expression, Expression)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Attribute -> Expression
ExDispatch Expression
dispatched Attribute
attr, Expression
scope)
buildExpression (ExApplication Expression
expr (BiTau Attribute
battr Expression
bexpr)) Subst
subst = do
  (Expression
applied, Expression
scope) <- Expression -> Subst -> Maybe (Expression, Expression)
buildExpression Expression
expr Subst
subst
  [Binding
binding] <- Binding -> Subst -> Maybe [Binding]
buildBinding (Attribute -> Expression -> Binding
BiTau Attribute
battr Expression
bexpr) Subst
subst
  (Expression, Expression) -> Maybe (Expression, Expression)
forall a. a -> Maybe a
Just (Expression -> Binding -> Expression
ExApplication Expression
applied Binding
binding, Expression
scope)
buildExpression (ExApplication Expression
_ Binding
_) Subst
_ = Maybe (Expression, Expression)
forall a. Maybe a
Nothing
buildExpression (ExFormation [Binding]
bds) Subst
subst = do
  [Binding]
bds' <- [Binding] -> Subst -> Maybe [Binding]
buildBindings [Binding]
bds Subst
subst
  (Expression, Expression) -> Maybe (Expression, Expression)
forall a. a -> Maybe a
Just ([Binding] -> Expression
ExFormation [Binding]
bds', Expression
defaultScope)
buildExpression (ExMeta String
meta) (Subst Map String MetaValue
mp) = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
meta Map String MetaValue
mp of
  Just (MvExpression Expression
expr Expression
scope) -> (Expression, Expression) -> Maybe (Expression, Expression)
forall a. a -> Maybe a
Just (Expression
expr, Expression
scope)
  Maybe MetaValue
_ -> Maybe (Expression, Expression)
forall a. Maybe a
Nothing
buildExpression (ExMetaTail Expression
expr String
meta) Subst
subst = do
  let (Subst Map String MetaValue
mp) = Subst
subst
  (Expression
expression, Expression
scope) <- Expression -> Subst -> Maybe (Expression, Expression)
buildExpression Expression
expr Subst
subst
  case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
meta Map String MetaValue
mp of
    Just (MvTail [Tail]
tails) -> (Expression, Expression) -> Maybe (Expression, Expression)
forall a. a -> Maybe a
Just (Expression -> [Tail] -> Subst -> Expression
buildExpressionWithTails Expression
expression [Tail]
tails Subst
subst, Expression
scope)
    Maybe MetaValue
_ -> Maybe (Expression, Expression)
forall a. Maybe a
Nothing
buildExpression Expression
expr Subst
_ = (Expression, Expression) -> Maybe (Expression, Expression)
forall a. a -> Maybe a
Just (Expression
expr, Expression
defaultScope)

buildBytesThrows :: Bytes -> Subst -> IO Bytes
buildBytesThrows :: Bytes -> Subst -> IO Bytes
buildBytesThrows Bytes
bytes Subst
subst = case Bytes -> Subst -> Maybe Bytes
buildBytes Bytes
bytes Subst
subst of
  Just Bytes
bts -> Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bytes
bts
  Maybe Bytes
_ -> BuildException -> IO Bytes
forall e a. Exception e => e -> IO a
throwIO (Bytes -> Subst -> BuildException
CouldNotBuildBytes Bytes
bytes Subst
subst)

buildBindingThrows :: Binding -> Subst -> IO [Binding]
buildBindingThrows :: Binding -> Subst -> IO [Binding]
buildBindingThrows Binding
bd Subst
subst = case Binding -> Subst -> Maybe [Binding]
buildBinding Binding
bd Subst
subst of
  Just [Binding]
bds -> [Binding] -> IO [Binding]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Binding]
bds
  Maybe [Binding]
_ -> BuildException -> IO [Binding]
forall e a. Exception e => e -> IO a
throwIO (Binding -> Subst -> BuildException
CouldNotBuildBinding Binding
bd Subst
subst)

buildAttributeThrows :: Attribute -> Subst -> IO Attribute
buildAttributeThrows :: Attribute -> Subst -> IO Attribute
buildAttributeThrows Attribute
attr Subst
subst = case Attribute -> Subst -> Maybe Attribute
buildAttribute Attribute
attr Subst
subst of
  Just Attribute
attr' -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
attr'
  Maybe Attribute
_ -> BuildException -> IO Attribute
forall e a. Exception e => e -> IO a
throwIO (Attribute -> Subst -> BuildException
CouldNotBuildAttribute Attribute
attr Subst
subst)

buildExpressionThrows :: Expression -> Subst -> IO (Expression, Expression)
buildExpressionThrows :: Expression -> Subst -> IO (Expression, Expression)
buildExpressionThrows Expression
expr Subst
subst = case Expression -> Subst -> Maybe (Expression, Expression)
buildExpression Expression
expr Subst
subst of
  Just (Expression, Expression)
built -> (Expression, Expression) -> IO (Expression, Expression)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression, Expression)
built
  Maybe (Expression, Expression)
_ -> BuildException -> IO (Expression, Expression)
forall e a. Exception e => e -> IO a
throwIO (Expression -> Subst -> BuildException
CouldNotBuildExpression Expression
expr Subst
subst)

-- Build a several expression from one expression and several substitutions
buildExpressions :: Expression -> [Subst] -> IO [(Expression, Expression)]
buildExpressions :: Expression -> [Subst] -> IO [(Expression, Expression)]
buildExpressions Expression
expr = (Subst -> IO (Expression, Expression))
-> [Subst] -> IO [(Expression, Expression)]
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) -> [a] -> f [b]
traverse (Expression -> Subst -> IO (Expression, Expression)
buildExpressionThrows Expression
expr)