{-# 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 Misc (uniqueBindings)
import Pretty (prettyAttribute, prettyBinding, prettyBytes, prettyExpression, prettySubst)
import Text.Printf (printf)
import Yaml (ExtraArgument (..))

data BuildException
  = CouldNotBuildExpression {BuildException -> Expression
_expr :: Expression, BuildException -> String
_msg :: String}
  | CouldNotBuildAttribute {BuildException -> Attribute
_attr :: Attribute, _msg :: String}
  | CouldNotBuildBinding {BuildException -> Binding
_bd :: Binding, _msg :: String}
  | CouldNotBuildBytes {BuildException -> Bytes
_bts :: Bytes, _msg :: String}
  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)

metaMsg :: String -> String
metaMsg :: String -> String
metaMsg = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"meta '%s' is either does not exist or refers to an inappropriate term"

type Built a = Either String a

-- @todo #277:30min Error messages are too verbose. Now, if we can't build expression or binding, we
--  throw an exception and just print whole expression or binding to console.
--  If this elements are big, it's just a mess and error message became unreadable. It would be nice to
--  print expression or binding in some reduce way, removing some parts or printing only first N lines
instance Show BuildException where
  show :: BuildException -> String
show CouldNotBuildExpression {String
Expression
_expr :: BuildException -> Expression
_msg :: BuildException -> String
_expr :: Expression
_msg :: String
..} =
    String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
      String
"Couldn't build expression, %s\n--Expression: %s"
      String
_msg
      (Expression -> String
prettyExpression Expression
_expr)
  show CouldNotBuildAttribute {String
Attribute
_msg :: BuildException -> String
_attr :: BuildException -> Attribute
_attr :: Attribute
_msg :: String
..} =
    String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
      String
"Couldn't build attribute '%s', %s"
      (Attribute -> String
prettyAttribute Attribute
_attr)
      String
_msg
  show CouldNotBuildBinding {String
Binding
_msg :: BuildException -> String
_bd :: BuildException -> Binding
_bd :: Binding
_msg :: String
..} =
    String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
      String
"Couldn't build binding, %s\n--Binding: %s"
      String
_msg
      (Binding -> String
prettyBinding Binding
_bd)
  show CouldNotBuildBytes {String
Bytes
_msg :: BuildException -> String
_bts :: BuildException -> Bytes
_bts :: Bytes
_msg :: String
..} =
    String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
      String
"Couldn't build bytes '%s', %s"
      (Bytes -> String
prettyBytes Bytes
_bts)
      String
_msg

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 -> Built Attribute
buildAttribute :: Attribute -> Subst -> Built 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 -> Built Attribute
forall a b. b -> Either a b
Right Attribute
attr
  Maybe MetaValue
_ -> String -> Built Attribute
forall a b. a -> Either a b
Left (String -> String
metaMsg String
meta)
buildAttribute Attribute
attr Subst
_ = Attribute -> Built Attribute
forall a b. b -> Either a b
Right Attribute
attr

buildBytes :: Bytes -> Subst -> Built Bytes
buildBytes :: Bytes -> Subst -> Built 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 -> Built Bytes
forall a b. b -> Either a b
Right Bytes
bytes
  Maybe MetaValue
_ -> String -> Built Bytes
forall a b. a -> Either a b
Left (String -> String
metaMsg String
meta)
buildBytes Bytes
bts Subst
_ = Bytes -> Built Bytes
forall a b. b -> Either a b
Right Bytes
bts

-- Build binding
-- The function returns [Binding] because the BiMeta is always attached
-- to the list of bindings
buildBinding :: Binding -> Subst -> Built [Binding]
buildBinding :: Binding -> Subst -> Built [Binding]
buildBinding (BiTau Attribute
attr Expression
expr) Subst
subst = do
  Attribute
attribute <- Attribute -> Subst -> Built Attribute
buildAttribute Attribute
attr Subst
subst
  (Expression
expression, Expression
_) <- Expression -> Subst -> Built (Expression, Expression)
buildExpression Expression
expr Subst
subst
  [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [Attribute -> Expression -> Binding
BiTau Attribute
attribute Expression
expression]
buildBinding (BiVoid Attribute
attr) Subst
subst = do
  Attribute
attribute <- Attribute -> Subst -> Built Attribute
buildAttribute Attribute
attr Subst
subst
  [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [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] -> Built [Binding]
uniqueBindings [Binding]
bds
  Maybe MetaValue
_ -> String -> Built [Binding]
forall a b. a -> Either a b
Left (String -> String
metaMsg String
meta)
buildBinding (BiDelta Bytes
bytes) Subst
subst = do
  Bytes
bts <- Bytes -> Subst -> Built Bytes
buildBytes Bytes
bytes Subst
subst
  [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [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] -> Built [Binding]
forall a b. b -> Either a b
Right [String -> Binding
BiLambda String
func]
  Maybe MetaValue
_ -> String -> Built [Binding]
forall a b. a -> Either a b
Left (String -> String
metaMsg String
meta)
buildBinding Binding
binding Subst
_ = [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [Binding
binding]

-- Build bindings that may contain meta binding (BiMeta)
buildBindings :: [Binding] -> Subst -> Built [Binding]
buildBindings :: [Binding] -> Subst -> Built [Binding]
buildBindings [] Subst
_ = [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right []
buildBindings (Binding
bd : [Binding]
rest) Subst
subst = do
  [Binding]
first <- Binding -> Subst -> Built [Binding]
buildBinding Binding
bd Subst
subst
  [Binding]
bds <- [Binding] -> Subst -> Built [Binding]
buildBindings [Binding]
rest Subst
subst
  [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right ([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 -> Built (Expression, Expression)
buildExpression :: Expression -> Subst -> Built (Expression, Expression)
buildExpression (ExDispatch Expression
expr Attribute
attr) Subst
subst = do
  (Expression
dispatched, Expression
scope) <- Expression -> Subst -> Built (Expression, Expression)
buildExpression Expression
expr Subst
subst
  Attribute
attr <- Attribute -> Subst -> Built Attribute
buildAttribute Attribute
attr Subst
subst
  (Expression, Expression) -> Built (Expression, Expression)
forall a b. b -> Either a b
Right (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 -> Built (Expression, Expression)
buildExpression Expression
expr Subst
subst
  [Binding]
bds <- Binding -> Subst -> Built [Binding]
buildBinding (Attribute -> Expression -> Binding
BiTau Attribute
battr Expression
bexpr) Subst
subst
  (Expression, Expression) -> Built (Expression, Expression)
forall a b. b -> Either a b
Right (Expression -> Binding -> Expression
ExApplication Expression
applied ([Binding] -> Binding
forall a. HasCallStack => [a] -> a
head [Binding]
bds), Expression
scope)
buildExpression (ExFormation [Binding]
bds) Subst
subst = do
  [Binding]
bds' <- [Binding] -> Subst -> Built [Binding]
buildBindings [Binding]
bds Subst
subst Built [Binding]
-> ([Binding] -> Built [Binding]) -> Built [Binding]
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Binding] -> Built [Binding]
uniqueBindings
  (Expression, Expression) -> Built (Expression, Expression)
forall a b. b -> Either a b
Right ([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) ->
    let res :: Either a (Expression, Expression)
res = (Expression, Expression) -> Either a (Expression, Expression)
forall a b. b -> Either a b
Right (Expression
expr, Expression
scope)
     in case Expression
expr of
          ExFormation [Binding]
bds -> [Binding] -> Built [Binding]
uniqueBindings [Binding]
bds Built [Binding]
-> Built (Expression, Expression) -> Built (Expression, Expression)
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Built (Expression, Expression)
forall {a}. Either a (Expression, Expression)
res
          Expression
_ -> Built (Expression, Expression)
forall {a}. Either a (Expression, Expression)
res
  Maybe MetaValue
_ -> String -> Built (Expression, Expression)
forall a b. a -> Either a b
Left (String -> String
metaMsg String
meta)
buildExpression (ExMetaTail Expression
expr String
meta) Subst
subst = do
  let (Subst Map String MetaValue
mp) = Subst
subst
  (Expression
expression, Expression
scope) <- Expression -> Subst -> Built (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) -> Built (Expression, Expression)
forall a b. b -> Either a b
Right (Expression -> [Tail] -> Subst -> Expression
buildExpressionWithTails Expression
expression [Tail]
tails Subst
subst, Expression
scope)
    Maybe MetaValue
_ -> String -> Built (Expression, Expression)
forall a b. a -> Either a b
Left (String -> String
metaMsg String
meta)
buildExpression Expression
expr Subst
_ = (Expression, Expression) -> Built (Expression, Expression)
forall a b. b -> Either a b
Right (Expression
expr, Expression
defaultScope)

buildBytesThrows :: Bytes -> Subst -> IO Bytes
buildBytesThrows :: Bytes -> Subst -> IO Bytes
buildBytesThrows Bytes
bytes Subst
subst = case Bytes -> Subst -> Built Bytes
buildBytes Bytes
bytes Subst
subst of
  Right Bytes
bts -> Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bytes
bts
  Left String
msg -> BuildException -> IO Bytes
forall e a. Exception e => e -> IO a
throwIO (Bytes -> String -> BuildException
CouldNotBuildBytes Bytes
bytes String
msg)

buildBindingThrows :: Binding -> Subst -> IO [Binding]
buildBindingThrows :: Binding -> Subst -> IO [Binding]
buildBindingThrows Binding
bd Subst
subst = case Binding -> Subst -> Built [Binding]
buildBinding Binding
bd Subst
subst of
  Right [Binding]
bds -> [Binding] -> IO [Binding]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Binding]
bds
  Left String
msg -> BuildException -> IO [Binding]
forall e a. Exception e => e -> IO a
throwIO (Binding -> String -> BuildException
CouldNotBuildBinding Binding
bd String
msg)

buildAttributeThrows :: Attribute -> Subst -> IO Attribute
buildAttributeThrows :: Attribute -> Subst -> IO Attribute
buildAttributeThrows Attribute
attr Subst
subst = case Attribute -> Subst -> Built Attribute
buildAttribute Attribute
attr Subst
subst of
  Right Attribute
attr' -> Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
attr'
  Left String
msg -> BuildException -> IO Attribute
forall e a. Exception e => e -> IO a
throwIO (Attribute -> String -> BuildException
CouldNotBuildAttribute Attribute
attr String
msg)

buildExpressionThrows :: Expression -> Subst -> IO (Expression, Expression)
buildExpressionThrows :: Expression -> Subst -> IO (Expression, Expression)
buildExpressionThrows Expression
expr Subst
subst = case Expression -> Subst -> Built (Expression, Expression)
buildExpression Expression
expr Subst
subst of
  Right (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
  Left String
msg -> BuildException -> IO (Expression, Expression)
forall e a. Exception e => e -> IO a
throwIO (Expression -> String -> BuildException
CouldNotBuildExpression Expression
expr String
msg)

-- 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)