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

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

module Builder
  ( buildExpressionsThrows
  , buildExpression
  , buildExpressionThrows
  , buildAttribute
  , buildAttributeThrows
  , buildBinding
  , buildBindingThrows
  , buildBindingUnchecked
  , buildBytes
  , buildBytesThrows
  , formed
  , nameIn
  , pathOf
  , BuildException (..)
  )
where

import AST
import Control.Exception (Exception, throw)
import Control.Monad (zipWithM)
import Data.List (find)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Matcher
import Misc (orThrow, uniqueBindings)
import Printer
import Text.Printf (printf)

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 :: Text -> String
metaMsg :: Text -> 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" (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

slotMsg :: Slot -> String
slotMsg :: Slot -> String
slotMsg (Slot Text
kind Int
_) = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"anonymous meta '!%s' cannot be referenced" (Text -> String
T.unpack Text
kind)

type Built a = Either String a

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
printExpression 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
printAttribute 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
printBinding 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
printBytes Bytes
_bts) String
_msg

buildAttribute :: Attribute -> Subst -> Built Attribute
buildAttribute :: Attribute -> Subst -> Built Attribute
buildAttribute (AtMeta Text
meta) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Meta
Named Text
meta) Map Meta 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 (Text -> String
metaMsg Text
meta)
buildAttribute (AtAny Slot
slot) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Slot -> Meta
Anon Slot
slot) Map Meta 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 (Slot -> String
slotMsg Slot
slot)
buildAttribute Attribute
attr Subst
_ = Attribute -> Built Attribute
forall a b. b -> Either a b
Right Attribute
attr

buildAlpha :: Alpha -> Subst -> Built Alpha
buildAlpha :: Alpha -> Subst -> Built Alpha
buildAlpha (AlMeta Text
meta) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Meta
Named Text
meta) Map Meta MetaValue
mp of
  Just (MvIndex Int
idx) -> Alpha -> Built Alpha
forall a b. b -> Either a b
Right (Int -> Alpha
Alpha Int
idx)
  Maybe MetaValue
_ -> String -> Built Alpha
forall a b. a -> Either a b
Left (Text -> String
metaMsg Text
meta)
buildAlpha (AlAny Slot
slot) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Slot -> Meta
Anon Slot
slot) Map Meta MetaValue
mp of
  Just (MvIndex Int
idx) -> Alpha -> Built Alpha
forall a b. b -> Either a b
Right (Int -> Alpha
Alpha Int
idx)
  Maybe MetaValue
_ -> String -> Built Alpha
forall a b. a -> Either a b
Left (Slot -> String
slotMsg Slot
slot)
buildAlpha Alpha
a Subst
_ = Alpha -> Built Alpha
forall a b. b -> Either a b
Right Alpha
a

buildBytes :: Bytes -> Subst -> Built Bytes
buildBytes :: Bytes -> Subst -> Built Bytes
buildBytes (BtMeta Text
meta) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Meta
Named Text
meta) Map Meta 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 (Text -> String
metaMsg Text
meta)
buildBytes (BtAny Slot
slot) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Slot -> Meta
Anon Slot
slot) Map Meta 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 (Slot -> String
slotMsg Slot
slot)
buildBytes Bytes
bts Subst
_ = Bytes -> Built Bytes
forall a b. b -> Either a b
Right Bytes
bts

buildBinding :: Binding -> Subst -> Built [Binding]
buildBinding :: Binding -> Subst -> Built [Binding]
buildBinding Binding
bd Subst
subst = Binding -> Subst -> Built [Binding]
buildBindingUnchecked Binding
bd 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

buildBindingUnchecked :: Binding -> Subst -> Built [Binding]
buildBindingUnchecked :: Binding -> Subst -> Built [Binding]
buildBindingUnchecked (BiTau Attribute
attr Expression
expr) Subst
subst = do
  Attribute
attribute <- Attribute -> Subst -> Built Attribute
buildAttribute Attribute
attr Subst
subst
  Expression
expression <- Expression -> Subst -> Built 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]
buildBindingUnchecked (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]
buildBindingUnchecked (BiMeta Text
meta) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Meta
Named Text
meta) Map Meta MetaValue
mp of
  Just (MvBindings [Binding]
bds) -> [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [Binding]
bds
  Maybe MetaValue
_ -> String -> Built [Binding]
forall a b. a -> Either a b
Left (Text -> String
metaMsg Text
meta)
buildBindingUnchecked (BiAny Slot
slot) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Slot -> Meta
Anon Slot
slot) Map Meta MetaValue
mp of
  Just (MvBindings [Binding]
bds) -> [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [Binding]
bds
  Maybe MetaValue
_ -> String -> Built [Binding]
forall a b. a -> Either a b
Left (Slot -> String
slotMsg Slot
slot)
buildBindingUnchecked (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]
buildBindingUnchecked (BiLambda (FnMeta Text
meta)) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Meta
Named Text
meta) Map Meta MetaValue
mp of
  Just (MvFunction Function
func) -> [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [Function -> Binding
BiLambda Function
func]
  Maybe MetaValue
_ -> String -> Built [Binding]
forall a b. a -> Either a b
Left (Text -> String
metaMsg Text
meta)
buildBindingUnchecked (BiLambda (FnAny Slot
slot)) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Slot -> Meta
Anon Slot
slot) Map Meta MetaValue
mp of
  Just (MvFunction Function
func) -> [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [Function -> Binding
BiLambda Function
func]
  Maybe MetaValue
_ -> String -> Built [Binding]
forall a b. a -> Either a b
Left (Slot -> String
slotMsg Slot
slot)
buildBindingUnchecked (BiLambda (FnFresh Slot
slot)) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Slot -> Meta
Anon Slot
slot) Map Meta MetaValue
mp of
  Just (MvFunction Function
func) -> [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [Function -> Binding
BiLambda Function
func]
  Maybe MetaValue
_ -> String -> Built [Binding]
forall a b. a -> Either a b
Left (Slot -> String
slotMsg Slot
slot)
buildBindingUnchecked Binding
binding Subst
_ = [Binding] -> Built [Binding]
forall a b. b -> Either a b
Right [Binding
binding]

buildArgument :: Argument -> Subst -> Built Argument
buildArgument :: Argument -> Subst -> Built Argument
buildArgument (ArTau Attribute
attr Expression
expr) Subst
subst = do
  Attribute
attribute <- Attribute -> Subst -> Built Attribute
buildAttribute Attribute
attr Subst
subst
  Expression
expression <- Expression -> Subst -> Built Expression
buildExpression Expression
expr Subst
subst
  Argument -> Built Argument
forall a b. b -> Either a b
Right (Attribute -> Expression -> Argument
ArTau Attribute
attribute Expression
expression)
buildArgument (ArAlpha Alpha
alpha Expression
expr) Subst
subst = do
  Alpha
alpha' <- Alpha -> Subst -> Built Alpha
buildAlpha Alpha
alpha Subst
subst
  Expression
expression <- Expression -> Subst -> Built Expression
buildExpression Expression
expr Subst
subst
  Argument -> Built Argument
forall a b. b -> Either a b
Right (Alpha -> Expression -> Argument
ArAlpha Alpha
alpha' Expression
expression)

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

pathOf :: Expression -> Expression -> Expression
pathOf :: Expression -> Expression -> Expression
pathOf universe :: Expression
universe@(ExFormation [Binding]
world) form :: Expression
form@(ExFormation [Binding]
bds)
  | Expression
form Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
universe = Expression
ExRoot
  | Bool
otherwise = Expression
-> ((Expression, [Binding]) -> Expression)
-> Maybe (Expression, [Binding])
-> Expression
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expression
form (Expression, [Binding]) -> Expression
found (Maybe Binding -> Maybe (Expression, [Binding])
parent ((Binding -> Bool) -> [Binding] -> Maybe Binding
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Binding -> Bool
rho [Binding]
bds))
  where
    found :: (Expression, [Binding]) -> Expression
    found :: (Expression, [Binding]) -> Expression
found (Expression
path, [Binding]
siblings) = Expression -> Maybe Expression -> Expression
forall a. a -> Maybe a -> a
fromMaybe Expression
form ([Expression] -> Maybe Expression
forall a. [a] -> Maybe a
listToMaybe ((Binding -> Maybe Expression) -> [Binding] -> [Expression]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Expression -> Binding -> Maybe Expression
candidate Expression
path) [Binding]
siblings))
    parent :: Maybe Binding -> Maybe (Expression, [Binding])
    parent :: Maybe Binding -> Maybe (Expression, [Binding])
parent Maybe Binding
Nothing = (Expression, [Binding]) -> Maybe (Expression, [Binding])
forall a. a -> Maybe a
Just (Expression
ExRoot, [Binding]
world)
    parent (Just (BiTau Attribute
AtRho Expression
path)) = (,) Expression
path ([Binding] -> (Expression, [Binding]))
-> Maybe [Binding] -> Maybe (Expression, [Binding])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> Maybe [Binding]
declared Expression
path
    parent Maybe Binding
_ = Maybe (Expression, [Binding])
forall a. Maybe a
Nothing
    declared :: Expression -> Maybe [Binding]
    declared :: Expression -> Maybe [Binding]
declared Expression
ExRoot = [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just [Binding]
world
    declared (ExApplication Expression
target Argument
_) = Expression -> Maybe [Binding]
declared Expression
target
    declared (ExDispatch Expression
target Attribute
attr) = do
      [Binding]
outer <- Expression -> Maybe [Binding]
declared Expression
target
      BiTau Attribute
_ (ExFormation [Binding]
inner) <- (Binding -> Bool) -> [Binding] -> Maybe Binding
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Attribute -> Binding -> Bool
tau Attribute
attr) [Binding]
outer
      [Binding] -> Maybe [Binding]
forall a. a -> Maybe a
Just [Binding]
inner
    declared Expression
_ = Maybe [Binding]
forall a. Maybe a
Nothing
    candidate :: Expression -> Binding -> Maybe Expression
    candidate :: Expression -> Binding -> Maybe Expression
candidate Expression
path (BiTau Attribute
attr (ExFormation [Binding]
origin))
      | Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
/= Attribute
AtRho Bool -> Bool -> Bool
&& [Binding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binding]
origin Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Binding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binding]
bds = do
          [[Argument]]
args <- (Binding -> Binding -> Maybe [Argument])
-> [Binding] -> [Binding] -> Maybe [[Argument]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Expression -> Binding -> Binding -> Maybe [Argument]
argument Expression
path) [Binding]
origin [Binding]
bds
          Expression -> Maybe Expression
forall a. a -> Maybe a
Just ((Expression -> Argument -> Expression)
-> Expression -> [Argument] -> Expression
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expression -> Argument -> Expression
ExApplication (Expression -> Attribute -> Expression
ExDispatch Expression
path Attribute
attr) ([[Argument]] -> [Argument]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Argument]]
args))
    candidate Expression
_ Binding
_ = Maybe Expression
forall a. Maybe a
Nothing
    argument :: Expression -> Binding -> Binding -> Maybe [Argument]
    argument :: Expression -> Binding -> Binding -> Maybe [Argument]
argument Expression
path (BiVoid Attribute
AtRho) (BiTau Attribute
AtRho Expression
value)
      | Expression
value Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
path = [Argument] -> Maybe [Argument]
forall a. a -> Maybe a
Just []
    argument Expression
_ (BiVoid Attribute
attr) (BiTau Attribute
attr' Expression
value)
      | Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr' Bool -> Bool -> Bool
&& Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
/= Attribute
AtRho Bool -> Bool -> Bool
&& Expression -> Bool
closed Expression
value = [Argument] -> Maybe [Argument]
forall a. a -> Maybe a
Just [Attribute -> Expression -> Argument
ArTau Attribute
attr Expression
value]
    argument Expression
_ Binding
origin Binding
binding
      | Binding
origin Binding -> Binding -> Bool
forall a. Eq a => a -> a -> Bool
== Binding
binding = [Argument] -> Maybe [Argument]
forall a. a -> Maybe a
Just []
      | Bool
otherwise = Maybe [Argument]
forall a. Maybe a
Nothing
    rho :: Binding -> Bool
    rho :: Binding -> Bool
rho (BiTau Attribute
AtRho Expression
_) = Bool
True
    rho (BiVoid Attribute
AtRho) = Bool
True
    rho Binding
_ = Bool
False
    tau :: Attribute -> Binding -> Bool
    tau :: Attribute -> Binding -> Bool
tau Attribute
attr (BiTau Attribute
attr' Expression
_) = Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr'
    tau Attribute
_ Binding
_ = Bool
False
    closed :: Expression -> Bool
    closed :: Expression -> Bool
closed (ExFormation [Binding]
_) = Bool
True
    closed Expression
ExRoot = Bool
True
    closed Expression
ExTermination = Bool
True
    closed (ExApplication Expression
target (ArTau Attribute
_ Expression
value)) = Expression -> Bool
closed Expression
target Bool -> Bool -> Bool
&& Expression -> Bool
closed Expression
value
    closed (ExApplication Expression
target (ArAlpha Alpha
_ Expression
value)) = Expression -> Bool
closed Expression
target Bool -> Bool -> Bool
&& Expression -> Bool
closed Expression
value
    closed (ExDispatch Expression
target Attribute
_) = Expression -> Bool
closed Expression
target
    closed Expression
_ = Bool
False
pathOf Expression
_ Expression
form = Expression
form

nameIn :: Maybe Expression -> Expression -> Expression
nameIn :: Maybe Expression -> Expression -> Expression
nameIn Maybe Expression
universe Expression
form = Expression
-> (Expression -> Expression) -> Maybe Expression -> Expression
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expression
form (Expression -> Expression -> Expression
`pathOf` Expression
form) Maybe Expression
universe

formed :: [Binding] -> Expression
formed :: [Binding] -> Expression
formed [Binding]
bds = (String -> Expression)
-> (Expression -> Expression) -> Built Expression -> Expression
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (BuildException -> Expression
forall a e. Exception e => e -> a
throw (BuildException -> Expression)
-> (String -> BuildException) -> String -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> String -> BuildException
CouldNotBuildExpression ([Binding] -> Expression
ExFormation [Binding]
bds)) Expression -> Expression
forall a. a -> a
id (Expression -> Built Expression
unique ([Binding] -> Expression
ExFormation [Binding]
bds))

unique :: Expression -> Built Expression
unique :: Expression -> Built Expression
unique expr :: Expression
expr@(ExFormation [Binding]
bds)
  | Expression -> Bool
distinct Expression
expr = Expression -> Built Expression
forall a b. b -> Either a b
Right Expression
expr
  | Bool
otherwise = [Binding] -> Built [Binding]
uniqueBindings [Binding]
bds Built [Binding] -> Built Expression -> Built 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
>> Expression -> Built Expression
forall a b. b -> Either a b
Right Expression
expr
unique Expression
expr = Expression -> Built Expression
forall a b. b -> Either a b
Right Expression
expr

buildExpression :: Expression -> Subst -> Built Expression
buildExpression :: Expression -> Subst -> Built Expression
buildExpression (ExDispatch Expression
ex Attribute
at) Subst
subst = do
  Expression
dispatched <- Expression -> Subst -> Built Expression
buildExpression Expression
ex Subst
subst
  Attribute
at' <- Attribute -> Subst -> Built Attribute
buildAttribute Attribute
at Subst
subst
  Expression -> Built Expression
forall a b. b -> Either a b
Right (Expression -> Attribute -> Expression
ExDispatch Expression
dispatched Attribute
at')
buildExpression (ExApplication Expression
ExRoot (ArTau Attribute
AtRho Expression
expr)) Subst
subst = do
  Expression
_ <- Expression -> Subst -> Built Expression
buildExpression Expression
expr Subst
subst
  Expression -> Built Expression
forall a b. b -> Either a b
Right Expression
ExRoot
buildExpression (ExApplication Expression
expr Argument
arg) Subst
subst = do
  Expression
applied <- Expression -> Subst -> Built Expression
buildExpression Expression
expr Subst
subst
  Argument
arg' <- Argument -> Subst -> Built Argument
buildArgument Argument
arg Subst
subst
  Expression -> Built Expression
forall a b. b -> Either a b
Right (Expression -> Argument -> Expression
ExApplication Expression
applied Argument
arg')
buildExpression (ExFormation [Binding]
bds) Subst
subst = [Binding] -> Subst -> Built [Binding]
buildBindings [Binding]
bds Subst
subst Built [Binding]
-> ([Binding] -> Built Expression) -> Built Expression
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
>>= Expression -> Built Expression
unique (Expression -> Built Expression)
-> ([Binding] -> Expression) -> [Binding] -> Built Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Binding] -> Expression
ExFormation
buildExpression (ExMeta Text
meta) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Meta
Named Text
meta) Map Meta MetaValue
mp of
  Just (MvExpression Expression
expr) -> Expression -> Built Expression
unique Expression
expr
  Maybe MetaValue
_ -> String -> Built Expression
forall a b. a -> Either a b
Left (Text -> String
metaMsg Text
meta)
buildExpression (ExAny Slot
slot) (Subst Map Meta MetaValue
mp) = case Meta -> Map Meta MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Slot -> Meta
Anon Slot
slot) Map Meta MetaValue
mp of
  Just (MvExpression Expression
expr) -> Expression -> Built Expression
unique Expression
expr
  Maybe MetaValue
_ -> String -> Built Expression
forall a b. a -> Either a b
Left (Slot -> String
slotMsg Slot
slot)
buildExpression Expression
expr Subst
_ = Expression -> Built Expression
forall a b. b -> Either a b
Right Expression
expr

buildBytesThrows :: Bytes -> Subst -> IO Bytes
buildBytesThrows :: Bytes -> Subst -> IO Bytes
buildBytesThrows Bytes
bytes Subst
subst = (String -> BuildException) -> Built Bytes -> IO Bytes
forall e a. Exception e => (String -> e) -> Either String a -> IO a
orThrow (Bytes -> String -> BuildException
CouldNotBuildBytes Bytes
bytes) (Bytes -> Subst -> Built Bytes
buildBytes Bytes
bytes Subst
subst)

buildBindingThrows :: Binding -> Subst -> IO [Binding]
buildBindingThrows :: Binding -> Subst -> IO [Binding]
buildBindingThrows Binding
bd Subst
subst = (String -> BuildException) -> Built [Binding] -> IO [Binding]
forall e a. Exception e => (String -> e) -> Either String a -> IO a
orThrow (Binding -> String -> BuildException
CouldNotBuildBinding Binding
bd) (Binding -> Subst -> Built [Binding]
buildBinding Binding
bd Subst
subst)

buildAttributeThrows :: Attribute -> Subst -> IO Attribute
buildAttributeThrows :: Attribute -> Subst -> IO Attribute
buildAttributeThrows Attribute
attr Subst
subst = (String -> BuildException) -> Built Attribute -> IO Attribute
forall e a. Exception e => (String -> e) -> Either String a -> IO a
orThrow (Attribute -> String -> BuildException
CouldNotBuildAttribute Attribute
attr) (Attribute -> Subst -> Built Attribute
buildAttribute Attribute
attr Subst
subst)

buildExpressionThrows :: Expression -> Subst -> IO Expression
buildExpressionThrows :: Expression -> Subst -> IO Expression
buildExpressionThrows Expression
expr Subst
subst = (String -> BuildException) -> Built Expression -> IO Expression
forall e a. Exception e => (String -> e) -> Either String a -> IO a
orThrow (Expression -> String -> BuildException
CouldNotBuildExpression Expression
expr) (Expression -> Subst -> Built Expression
buildExpression Expression
expr Subst
subst)

buildExpressionsThrows :: Expression -> [Subst] -> IO [Expression]
buildExpressionsThrows :: Expression -> [Subst] -> IO [Expression]
buildExpressionsThrows Expression
expr = (Subst -> IO Expression) -> [Subst] -> IO [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
buildExpressionThrows Expression
expr)