{-# LANGUAGE OverloadedStrings #-}

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

module Tau (seedTaus, freshTau) where

import AST
import Data.IORef (IORef, atomicModifyIORef', newIORef, writeIORef)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import GHC.IO (unsafePerformIO)

taus :: IORef (Set Text, Int)
{-# NOINLINE taus #-}
taus :: IORef (Set Text, Int)
taus = IO (IORef (Set Text, Int)) -> IORef (Set Text, Int)
forall a. IO a -> a
unsafePerformIO ((Set Text, Int) -> IO (IORef (Set Text, Int))
forall a. a -> IO (IORef a)
newIORef (Set Text
forall a. Set a
Set.empty, Int
0))

seedTaus :: Expression -> IO ()
seedTaus :: Expression -> IO ()
seedTaus Expression
expr = IORef (Set Text, Int) -> (Set Text, Int) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Set Text, Int)
taus (Expression -> Set Text
exprLabels Expression
expr, Int
0)

freshTau :: IO Text
freshTau :: IO Text
freshTau = IORef (Set Text, Int)
-> ((Set Text, Int) -> ((Set Text, Int), Text)) -> IO Text
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Set Text, Int)
taus (Set Text, Int) -> ((Set Text, Int), Text)
advance
  where
    advance :: (Set Text, Int) -> ((Set Text, Int), Text)
advance (Set Text
taken, Int
cursor) =
      let (Text
minted, Int
idx) = Set Text -> Int -> (Text, Int)
mint Set Text
taken Int
cursor
       in ((Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
minted Set Text
taken, Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1), Text
minted)

mint :: Set Text -> Int -> (Text, Int)
mint :: Set Text -> Int -> (Text, Int)
mint Set Text
taken Int
idx
  | Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
taken = Set Text -> Int -> (Text, Int)
mint Set Text
taken (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  | Bool
otherwise = (Text
name, Int
idx)
  where
    name :: Text
    name :: Text
name = Text
"a🌵" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
idx)

exprLabels :: Expression -> Set Text
exprLabels :: Expression -> Set Text
exprLabels (ExFormation [Binding]
bds) = [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((Binding -> Set Text) -> [Binding] -> [Set Text]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Set Text
bindingLabels [Binding]
bds)
exprLabels (ExApplication Expression
expr Argument
arg) = Expression -> Set Text
exprLabels Expression
expr Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> Argument -> Set Text
argumentLabels Argument
arg
exprLabels (ExDispatch Expression
expr Attribute
attr) = Expression -> Set Text
exprLabels Expression
expr Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> Attribute -> Set Text
attrLabel Attribute
attr
exprLabels (ExPhiMeet Maybe String
_ Int
_ Expression
expr) = Expression -> Set Text
exprLabels Expression
expr
exprLabels (ExPhiAgain Maybe String
_ Int
_ Expression
expr) = Expression -> Set Text
exprLabels Expression
expr
exprLabels Expression
_ = Set Text
forall a. Set a
Set.empty

bindingLabels :: Binding -> Set Text
bindingLabels :: Binding -> Set Text
bindingLabels (BiTau Attribute
attr Expression
expr) = Attribute -> Set Text
attrLabel Attribute
attr Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> Expression -> Set Text
exprLabels Expression
expr
bindingLabels (BiVoid Attribute
attr) = Attribute -> Set Text
attrLabel Attribute
attr
bindingLabels Binding
_ = Set Text
forall a. Set a
Set.empty

argumentLabels :: Argument -> Set Text
argumentLabels :: Argument -> Set Text
argumentLabels (ArTau Attribute
attr Expression
expr) = Attribute -> Set Text
attrLabel Attribute
attr Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> Expression -> Set Text
exprLabels Expression
expr
argumentLabels (ArAlpha Alpha
_ Expression
expr) = Expression -> Set Text
exprLabels Expression
expr

attrLabel :: Attribute -> Set Text
attrLabel :: Attribute -> Set Text
attrLabel (AtLabel Text
label) = Text -> Set Text
forall a. a -> Set a
Set.singleton Text
label
attrLabel Attribute
_ = Set Text
forall a. Set a
Set.empty