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

module Metas (Metas (..), lonely) where

import AST
import Data.List (nub)
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Text.Read (readMaybe)

class Metas a where
  metas :: a -> [Text]

  bare :: [Text] -> a -> a

lonely :: (Metas a) => a -> a
lonely :: forall a. Metas a => a -> a
lonely a
term = [Text] -> a -> a
forall a. Metas a => [Text] -> a -> a
bare ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
alone [Text]
named) a
term
  where
    named :: [Text]
    named :: [Text]
named = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub (a -> [Text]
forall a. Metas a => a -> [Text]
metas a
term)
    alone :: Text -> Bool
    alone :: Text -> Bool
alone Text
name = Text -> Bool
indexed Text
name Bool -> Bool -> Bool
&& [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
kin Text
name) [Text]
named) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    kin :: Text -> Text -> Bool
    kin :: Text -> Text -> Bool
kin Text
name Text
other = Int -> Text -> Text
T.take Int
1 Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Text -> Text
T.take Int
1 Text
other
    indexed :: Text -> Bool
    indexed :: Text -> Bool
indexed Text
name = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack (Int -> Text -> Text
T.drop Int
1 Text
name)) :: Maybe Int)

instance Metas Text where
  metas :: Text -> [Text]
metas Text
name = [Text
name]
  bare :: [Text] -> Text -> Text
bare [Text]
names Text
name = if 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 then Int -> Text -> Text
T.take Int
1 Text
name else Text
name

instance Metas Slot where
  metas :: Slot -> [Text]
metas (Slot Text
kind Int
_) = [Text
kind]
  bare :: [Text] -> Slot -> Slot
bare [Text]
_ Slot
slot = Slot
slot

instance (Metas a) => Metas [a] where
  metas :: [a] -> [Text]
metas = (a -> [Text]) -> [a] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [Text]
forall a. Metas a => a -> [Text]
metas
  bare :: [Text] -> [a] -> [a]
bare [Text]
names = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> a -> a
forall a. Metas a => [Text] -> a -> a
bare [Text]
names)

instance (Metas a) => Metas (Maybe a) where
  metas :: Maybe a -> [Text]
metas = [Text] -> (a -> [Text]) -> Maybe a -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] a -> [Text]
forall a. Metas a => a -> [Text]
metas
  bare :: [Text] -> Maybe a -> Maybe a
bare [Text]
names = (a -> a) -> Maybe a -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> a -> a
forall a. Metas a => [Text] -> a -> a
bare [Text]
names)

instance Metas Expression where
  metas :: Expression -> [Text]
metas (ExMeta Text
name) = Text -> [Text]
forall a. Metas a => a -> [Text]
metas Text
name
  metas (ExAny Slot
slot) = Slot -> [Text]
forall a. Metas a => a -> [Text]
metas Slot
slot
  metas (ExFormation [Binding]
bds) = [Binding] -> [Text]
forall a. Metas a => a -> [Text]
metas [Binding]
bds
  metas (ExApplication Expression
expr Argument
arg) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Argument -> [Text]
forall a. Metas a => a -> [Text]
metas Argument
arg
  metas (ExDispatch Expression
expr Attribute
attr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Attribute -> [Text]
forall a. Metas a => a -> [Text]
metas Attribute
attr
  metas (ExPhiMeet Maybe String
_ Int
_ Expression
expr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  metas (ExPhiAgain Maybe String
_ Int
_ Expression
expr) = Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  metas (ExBytes Bytes
bts) = Bytes -> [Text]
forall a. Metas a => a -> [Text]
metas Bytes
bts
  metas Expression
_ = []
  bare :: [Text] -> Expression -> Expression
bare [Text]
names (ExMeta Text
name) = Text -> Expression
ExMeta ([Text] -> Text -> Text
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Text
name)
  bare [Text]
names (ExFormation [Binding]
bds) = [Binding] -> Expression
ExFormation ([Text] -> [Binding] -> [Binding]
forall a. Metas a => [Text] -> a -> a
bare [Text]
names [Binding]
bds)
  bare [Text]
names (ExApplication Expression
expr Argument
arg) = Expression -> Argument -> Expression
ExApplication ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr) ([Text] -> Argument -> Argument
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Argument
arg)
  bare [Text]
names (ExDispatch Expression
expr Attribute
attr) = Expression -> Attribute -> Expression
ExDispatch ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr) ([Text] -> Attribute -> Attribute
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Attribute
attr)
  bare [Text]
names (ExPhiMeet Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiMeet Maybe String
prefix Int
idx ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)
  bare [Text]
names (ExPhiAgain Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiAgain Maybe String
prefix Int
idx ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)
  bare [Text]
names (ExBytes Bytes
bts) = Bytes -> Expression
ExBytes ([Text] -> Bytes -> Bytes
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Bytes
bts)
  bare [Text]
_ Expression
expr = Expression
expr

instance Metas Argument where
  metas :: Argument -> [Text]
metas (ArTau Attribute
attr Expression
expr) = Attribute -> [Text]
forall a. Metas a => a -> [Text]
metas Attribute
attr [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  metas (ArAlpha Alpha
alpha Expression
expr) = Alpha -> [Text]
forall a. Metas a => a -> [Text]
metas Alpha
alpha [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  bare :: [Text] -> Argument -> Argument
bare [Text]
names (ArTau Attribute
attr Expression
expr) = Attribute -> Expression -> Argument
ArTau ([Text] -> Attribute -> Attribute
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Attribute
attr) ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)
  bare [Text]
names (ArAlpha Alpha
alpha Expression
expr) = Alpha -> Expression -> Argument
ArAlpha ([Text] -> Alpha -> Alpha
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Alpha
alpha) ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)

instance Metas Binding where
  metas :: Binding -> [Text]
metas (BiTau Attribute
attr Expression
expr) = Attribute -> [Text]
forall a. Metas a => a -> [Text]
metas Attribute
attr [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Expression -> [Text]
forall a. Metas a => a -> [Text]
metas Expression
expr
  metas (BiVoid Attribute
attr) = Attribute -> [Text]
forall a. Metas a => a -> [Text]
metas Attribute
attr
  metas (BiDelta Bytes
bts) = Bytes -> [Text]
forall a. Metas a => a -> [Text]
metas Bytes
bts
  metas (BiLambda Function
func) = Function -> [Text]
forall a. Metas a => a -> [Text]
metas Function
func
  metas (BiMeta Text
name) = Text -> [Text]
forall a. Metas a => a -> [Text]
metas Text
name
  metas (BiAny Slot
slot) = Slot -> [Text]
forall a. Metas a => a -> [Text]
metas Slot
slot
  bare :: [Text] -> Binding -> Binding
bare [Text]
names (BiTau Attribute
attr Expression
expr) = Attribute -> Expression -> Binding
BiTau ([Text] -> Attribute -> Attribute
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Attribute
attr) ([Text] -> Expression -> Expression
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Expression
expr)
  bare [Text]
names (BiVoid Attribute
attr) = Attribute -> Binding
BiVoid ([Text] -> Attribute -> Attribute
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Attribute
attr)
  bare [Text]
names (BiDelta Bytes
bts) = Bytes -> Binding
BiDelta ([Text] -> Bytes -> Bytes
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Bytes
bts)
  bare [Text]
names (BiLambda Function
func) = Function -> Binding
BiLambda ([Text] -> Function -> Function
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Function
func)
  bare [Text]
names (BiMeta Text
name) = Text -> Binding
BiMeta ([Text] -> Text -> Text
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Text
name)
  bare [Text]
_ Binding
bd = Binding
bd

instance Metas Attribute where
  metas :: Attribute -> [Text]
metas (AtMeta Text
name) = Text -> [Text]
forall a. Metas a => a -> [Text]
metas Text
name
  metas (AtAny Slot
slot) = Slot -> [Text]
forall a. Metas a => a -> [Text]
metas Slot
slot
  metas Attribute
_ = []
  bare :: [Text] -> Attribute -> Attribute
bare [Text]
names (AtMeta Text
name) = Text -> Attribute
AtMeta ([Text] -> Text -> Text
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Text
name)
  bare [Text]
_ Attribute
attr = Attribute
attr

instance Metas Alpha where
  metas :: Alpha -> [Text]
metas (AlMeta Text
name) = Text -> [Text]
forall a. Metas a => a -> [Text]
metas Text
name
  metas (AlAny Slot
slot) = Slot -> [Text]
forall a. Metas a => a -> [Text]
metas Slot
slot
  metas Alpha
_ = []
  bare :: [Text] -> Alpha -> Alpha
bare [Text]
names (AlMeta Text
name) = Text -> Alpha
AlMeta ([Text] -> Text -> Text
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Text
name)
  bare [Text]
_ Alpha
alpha = Alpha
alpha

instance Metas Bytes where
  metas :: Bytes -> [Text]
metas (BtMeta Text
name) = Text -> [Text]
forall a. Metas a => a -> [Text]
metas Text
name
  metas (BtAny Slot
slot) = Slot -> [Text]
forall a. Metas a => a -> [Text]
metas Slot
slot
  metas Bytes
_ = []
  bare :: [Text] -> Bytes -> Bytes
bare [Text]
names (BtMeta Text
name) = Text -> Bytes
BtMeta ([Text] -> Text -> Text
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Text
name)
  bare [Text]
_ Bytes
bts = Bytes
bts

instance Metas Function where
  metas :: Function -> [Text]
metas (FnMeta Text
name) = Text -> [Text]
forall a. Metas a => a -> [Text]
metas Text
name
  metas (FnAny Slot
slot) = Slot -> [Text]
forall a. Metas a => a -> [Text]
metas Slot
slot
  metas Function
_ = []
  bare :: [Text] -> Function -> Function
bare [Text]
names (FnMeta Text
name) = Text -> Function
FnMeta ([Text] -> Text -> Text
forall a. Metas a => [Text] -> a -> a
bare [Text]
names Text
name)
  bare [Text]
_ Function
func = Function
func