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

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

module Locator (LocatorException (..), locatedExpression, withLocatedExpression) where

import AST
import Control.Exception (Exception, throwIO)
import Data.Functor ((<&>))
import Misc
import Printer (printExpression)
import Text.Printf (printf)

data LocatorException
  = InvalidLocatorProvided {LocatorException -> Expression
fqn :: Expression}
  | CanNotFindObjectByLocator {fqn :: Expression}
  | CanNotHideWholeProgram {fqn :: Expression}
  deriving (Show LocatorException
Typeable LocatorException
(Typeable LocatorException, Show LocatorException) =>
(LocatorException -> SomeException)
-> (SomeException -> Maybe LocatorException)
-> (LocatorException -> String)
-> Exception LocatorException
SomeException -> Maybe LocatorException
LocatorException -> String
LocatorException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: LocatorException -> SomeException
toException :: LocatorException -> SomeException
$cfromException :: SomeException -> Maybe LocatorException
fromException :: SomeException -> Maybe LocatorException
$cdisplayException :: LocatorException -> String
displayException :: LocatorException -> String
Exception)

instance Show LocatorException where
  show :: LocatorException -> String
show InvalidLocatorProvided{Expression
fqn :: LocatorException -> Expression
fqn :: Expression
..} =
    String -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"Invalid locator is provided. 'Q' or dispatch started with 'Q' expected, but got: '%s'"
      (Expression -> String
printExpression Expression
fqn)
  show CanNotFindObjectByLocator{Expression
fqn :: LocatorException -> Expression
fqn :: Expression
..} = String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Can't find object by locator: '%s'" (Expression -> String
printExpression Expression
fqn)
  show CanNotHideWholeProgram{Expression
fqn :: LocatorException -> Expression
fqn :: Expression
..} =
    String -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"The --hide locator must name an attribute, '%s' would hide the whole program"
      (Expression -> String
printExpression Expression
fqn)

locatedExpression :: Expression -> Expression -> IO Expression
locatedExpression :: Expression -> Expression -> IO Expression
locatedExpression Expression
ExRoot Expression
expr = Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr
locatedExpression Expression
locator Expression
expr = case Expression -> Maybe [Attribute]
fqnToAttrs Expression
locator of
  Just [Attribute]
attrs -> Expression -> [Attribute] -> IO Expression
locatedExpression' Expression
expr [Attribute]
attrs
  Maybe [Attribute]
_ -> Expression -> IO Expression
forall a. Expression -> IO a
invalidLocator Expression
locator
  where
    locatedExpression' :: Expression -> [Attribute] -> IO Expression
    locatedExpression' :: Expression -> [Attribute] -> IO Expression
locatedExpression' Expression
expr' [] = Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr'
    locatedExpression' (ExFormation [Binding]
bds) [Attribute
attr] = case Attribute -> [Binding] -> Maybe Expression
locatedInBindings Attribute
attr [Binding]
bds of
      Just Expression
expr' -> Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr'
      Maybe Expression
_ -> Expression -> IO Expression
forall a. Expression -> IO a
cantFindBy Expression
locator
    locatedExpression' (ExFormation [Binding]
bds) (Attribute
attr : [Attribute]
rest) = case Attribute -> [Binding] -> Maybe Expression
locatedInBindings Attribute
attr [Binding]
bds of
      Just Expression
expr' -> Expression -> [Attribute] -> IO Expression
locatedExpression' Expression
expr' [Attribute]
rest
      Maybe Expression
_ -> Expression -> IO Expression
forall a. Expression -> IO a
cantFindBy Expression
locator
    locatedExpression' Expression
_ [Attribute]
_ = Expression -> IO Expression
forall a. Expression -> IO a
cantFindBy Expression
locator

withLocatedExpression :: Expression -> Expression -> Expression -> IO Expression
withLocatedExpression :: Expression -> Expression -> Expression -> IO Expression
withLocatedExpression Expression
ExRoot Expression
tgt Expression
_ = Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
tgt
withLocatedExpression Expression
locator Expression
target Expression
expr = case Expression -> Maybe [Attribute]
fqnToAttrs Expression
locator of
  Just [Attribute]
attrs -> Expression -> [Attribute] -> IO Expression
withLocatedExpression' Expression
expr [Attribute]
attrs
  Maybe [Attribute]
_ -> Expression -> IO Expression
forall a. Expression -> IO a
invalidLocator Expression
locator
  where
    withLocatedExpression' :: Expression -> [Attribute] -> IO Expression
    withLocatedExpression' :: Expression -> [Attribute] -> IO Expression
withLocatedExpression' (ExFormation [Binding]
bds) [Attribute
attr] = case Attribute -> [Binding] -> Maybe Expression
locatedInBindings Attribute
attr [Binding]
bds of
      Just Expression
_ -> Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding] -> Expression
ExFormation ([Binding] -> [Binding]
withReplacedExpression [Binding]
bds))
      Maybe Expression
_ -> Expression -> IO Expression
forall a. Expression -> IO a
cantFindBy Expression
locator
      where
        withReplacedExpression :: [Binding] -> [Binding]
        withReplacedExpression :: [Binding] -> [Binding]
withReplacedExpression [] = []
        withReplacedExpression (bd :: Binding
bd@(BiTau Attribute
at Expression
_) : [Binding]
bds')
          | Attribute
at Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr = Attribute -> Expression -> Binding
BiTau Attribute
at Expression
target Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bds'
          | Bool
otherwise = Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding] -> [Binding]
withReplacedExpression [Binding]
bds'
        withReplacedExpression (bd :: Binding
bd@(BiVoid Attribute
at) : [Binding]
bds')
          | Attribute
at Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr = Attribute -> Expression -> Binding
BiTau Attribute
at Expression
target Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bds'
          | Bool
otherwise = Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding] -> [Binding]
withReplacedExpression [Binding]
bds'
        withReplacedExpression (Binding
bd : [Binding]
bds') = Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding] -> [Binding]
withReplacedExpression [Binding]
bds'
    withLocatedExpression' (ExFormation [Binding]
bds) [Attribute]
attrs = [Binding] -> Expression
ExFormation ([Binding] -> Expression) -> IO [Binding] -> IO Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> [Attribute] -> IO [Binding]
withLocatedBindings [Binding]
bds [Attribute]
attrs
      where
        withLocatedBindings :: [Binding] -> [Attribute] -> IO [Binding]
        withLocatedBindings :: [Binding] -> [Attribute] -> IO [Binding]
withLocatedBindings (bd :: Binding
bd@(BiTau Attribute
at Expression
expr') : [Binding]
rbds) attrs' :: [Attribute]
attrs'@(Attribute
at' : [Attribute]
rattrs)
          | Attribute
at Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
at' = Expression -> [Attribute] -> IO Expression
withLocatedExpression' Expression
expr' [Attribute]
rattrs IO Expression -> (Expression -> [Binding]) -> IO [Binding]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
rbds) (Binding -> [Binding])
-> (Expression -> Binding) -> Expression -> [Binding]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute -> Expression -> Binding
BiTau Attribute
at
          | Bool
otherwise = [Binding] -> [Attribute] -> IO [Binding]
withLocatedBindings [Binding]
rbds [Attribute]
attrs' IO [Binding] -> ([Binding] -> [Binding]) -> IO [Binding]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (:) Binding
bd
        withLocatedBindings (Binding
bd : [Binding]
rbds) [Attribute]
attrs' = (:) Binding
bd ([Binding] -> [Binding]) -> IO [Binding] -> IO [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> [Attribute] -> IO [Binding]
withLocatedBindings [Binding]
rbds [Attribute]
attrs'
        withLocatedBindings [] [Attribute]
_ = Expression -> IO [Binding]
forall a. Expression -> IO a
cantFindBy Expression
locator
    withLocatedExpression' Expression
_ [Attribute]
_ = Expression -> IO Expression
forall a. Expression -> IO a
cantFindBy Expression
locator

locatedInBindings :: Attribute -> [Binding] -> Maybe Expression
locatedInBindings :: Attribute -> [Binding] -> Maybe Expression
locatedInBindings Attribute
_ [] = Maybe Expression
forall a. Maybe a
Nothing
locatedInBindings Attribute
attr (BiTau Attribute
attr' Expression
expr' : [Binding]
rest)
  | Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr' = Expression -> Maybe Expression
forall a. a -> Maybe a
Just Expression
expr'
  | Bool
otherwise = Attribute -> [Binding] -> Maybe Expression
locatedInBindings Attribute
attr [Binding]
rest
locatedInBindings Attribute
attr (Binding
_ : [Binding]
rest) = Attribute -> [Binding] -> Maybe Expression
locatedInBindings Attribute
attr [Binding]
rest

invalidLocator :: Expression -> IO a
invalidLocator :: forall a. Expression -> IO a
invalidLocator = LocatorException -> IO a
forall e a. Exception e => e -> IO a
throwIO (LocatorException -> IO a)
-> (Expression -> LocatorException) -> Expression -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> LocatorException
InvalidLocatorProvided

cantFindBy :: Expression -> IO a
cantFindBy :: forall a. Expression -> IO a
cantFindBy = LocatorException -> IO a
forall e a. Exception e => e -> IO a
throwIO (LocatorException -> IO a)
-> (Expression -> LocatorException) -> Expression -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> LocatorException
CanNotFindObjectByLocator